home *** CD-ROM | disk | FTP | other *** search
/ Piper's Pit BBS/FTP: ibm 0010 - 0019 / ibm0010-0019 / ibm0010.tar / ibm0010 / CADKEY_C.ZIP / CADKEY14.ZIP / CDL / TBMOD.CDL < prev    next >
Encoding:
Text File  |  1989-06-22  |  3.6 KB  |  168 lines
  1. REM ************************************************************************
  2. REM       Text template maker --- subroutine (tbmod.cdl)
  3.  
  4. REM    Purpose:  To allow the user to modify the fields, then write
  5. REM          the template description to an ASCII file
  6. REM ************************************************************************
  7.  
  8.  
  9. :ind_screen
  10.    DOSUB tbdisp
  11.    IF (retrn == 0)
  12.       GOTO redrw
  13.    GOTO set_devin
  14.  
  15. :redrw
  16.    REDRAW
  17.    GOTO exit
  18.  
  19. :set_devin
  20.    SET devin, $tplname
  21.    SET devout, tpf
  22.  
  23. :read_fld
  24.    INPUT "%d %s %d",sqnum,$tmp,nchar
  25.  
  26.    CLEAR    $fldtxt
  27.    ARRAY    $fldtxt[nchar+1]
  28.  
  29. REM   *** dummy read two characters
  30.    INPUT "%c %c",$fldtxt[0],$fldtxt[1]
  31.  
  32.    i = 0
  33. :txtloop
  34.    INPUT "%c",$fldtxt[i]
  35.    IF ($fldtxt[i] == 34)
  36.       GOTO read_more
  37.    i = i + 1
  38.    goto txtloop
  39.  
  40. :read_more
  41.    $fldtxt[i] = 0
  42.    INPUT "%f %f %f %f %f %d %d\n",dx,dy,fldlngth,txtht,asprat,font,pen
  43.  
  44. :screen
  45.    IF (sqnum == pnum)
  46.       GOTO mod_fld
  47.    IF (sqnum != 10000)
  48.       GOTO write_fld
  49.    GOTO last_line
  50.  
  51. :mod_fld
  52.    foundit = 1
  53.    GETMENU "Select option.",\
  54.             "NAME",\
  55.             "LIMITS",\
  56.             "TXT HGT",\
  57.             "ASP RAT",\
  58.             "FONT",\
  59.             "PEN",\
  60.             "DONE"
  61.    ON (@KEY + 3) GOTO exit,ind_screen,mod_fld,mod_fld,new_name,limits,\
  62.                  txt_ht,asp_rat,font,pen,get_deftxt,
  63.  
  64. :new_name
  65.    $tmp = " "
  66.    GETSTR "Enter new field name:%s",$tmp,$tmp
  67.    ON (@KEY + 3) GOTO exit,mod_fld,new_name,
  68.    CALL strlen, $tmp, lngth
  69.    IF (lngth > 8)
  70.       GOTO message3
  71.    IF (lngth == 0)
  72.       GOTO message4
  73.    CALL strcmp,$defstr,$tmp,match
  74.    IF (match == 0)
  75.       GOTO new_name
  76.    GOTO mod_fld
  77.  
  78. :limits
  79.    GETPOS  "Indicate new start position",def1
  80.    ON (@KEY + 3) GOTO exit,mod_fld,limits,
  81.    def1 = @KEY
  82.    fstx = @XVIEW
  83.    fsty = @YVIEW
  84.    dx = fstx - bpx
  85.    dy = fsty - bpy
  86.  
  87. :ind_fldnd
  88.    GETPOS  "Indicate new end position",def1
  89.    ON (@KEY + 3) GOTO exit,limits,ind_fldnd,
  90.    def1 = @KEY
  91.    fndx = @XVIEW
  92.    fndy = @YVIEW
  93.    IF (fndx < fstx)
  94.       GOTO message1
  95.    fldlngth = fndx - fstx
  96.    GOTO mod_fld
  97.  
  98. :txt_ht
  99.    GETFLT  "Enter new text hight (%f):",txtht,txtht
  100.    ON (@KEY + 3) GOTO exit,mod_fld,
  101.    GOTO mod_fld
  102.  
  103. :asp_rat
  104.    GETFLT  "Enter new aspect ratio (%f):",asprat,asprat
  105.    ON (@KEY + 3) GOTO exit,mod_fld,
  106.    GOTO mod_fld
  107.  
  108. :font
  109.    GETINT  "Enter text font number (%d):",font,font,
  110.    ON (@KEY + 3) GOTO exit,mod_fld,
  111.    GOTO mod_fld
  112.  
  113. :pen
  114.    GETINT  "Enter new pen number (%d):",pen,pen,
  115.    ON (@KEY + 3) GOTO exit,mod_fld,
  116.    GOTO mod_fld
  117.  
  118. :get_deftxt
  119.    nchar = floor(fldlngth / (txtht * asprat))
  120.    SPRINT $str1, "Enter new def. text. Max. %d ch.",nchar
  121.    $str2 = "(%s):"
  122.    CALL strcat, $str1, $str2
  123.    GETSTR $str1, $fldtxt, $fldtxt
  124.    ON (@KEY + 3) GOTO exit,mod_fld,
  125.    CALL strlen, $fldtxt, lngth
  126.    IF (lngth > nchar)
  127.       GOTO message2
  128.    GOTO write_fld
  129.  
  130. :write_fld
  131.    PRINT "%d %s %d \"%s\" %.4f %.4f %.4f %.4f %.4f %d %d\n",sqnum,$tmp,\
  132.           nchar,$fldtxt,dx,dy,fldlngth,txtht,asprat,font,pen
  133.    GOTO read_fld
  134.  
  135. :message1
  136.    PROMPT "Field limits error, try again..."
  137.    WAIT 2
  138.    GOTO limits
  139.  
  140. :message2
  141.    PROMPT "Too many characters for this field, try again..."
  142.    WAIT 2
  143.    $fldtxt = " "
  144.    GOTO get_deftxt
  145.  
  146. :message3
  147.    PROMPT "Too many characters ... try again."
  148.    WAIT 2
  149.    GOTO new_name
  150.  
  151. :message4
  152.    PROMPT "Field must be named ... try again."
  153.    WAIT 2
  154.    GOTO new_name
  155.  
  156. :last_line
  157.    PRINT "10000 end 3 \"end\" 0 0 0 0 0 1 1"
  158.    CLOSE devout
  159.    CLOSE devin
  160.    SPRINT $cmd,"copy tpf %s",$tplname
  161.    EXEC 1, $cmd
  162.    EXEC 1, "del tpf"
  163.    GOTO ind_screen
  164.  
  165. :exit
  166.    EXIT
  167.  
  168.