home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / compiler / fpc / source / seddraw.seq < prev    next >
Text File  |  1989-07-03  |  5KB  |  133 lines
  1. \ SEDDRAW.SEQ   Line drawing utility for SED            by Tom Zimmer
  2.  
  3. editor definitions
  4.  
  5. headerless
  6.  
  7. variable marginsave
  8. variable pendown
  9. variable 2line
  10.          2line off
  11.  
  12. : achr          ( --- )
  13.                 create ,
  14.                 does> @
  15.                 false save!> imode
  16.                 schr lchr
  17.                 showcur
  18.                 restore> imode ;
  19.  
  20. \ t-top, b-bottom, l-left, r-right, m-middle, 1-1line
  21.  
  22. $0DA achr tl1   $0BF achr tr1   $0D9 achr br1   $0C0 achr bl1
  23. $0B3 achr lr1   $0C4 achr tb1   $0C2 achr tm1   $0C1 achr bm1
  24. $0C3 achr lm1   $0B4 achr rm1   $0C5 achr mm1
  25. $0C9 achr tl2   $0BB achr tr2   $0BC achr br2   $0C8 achr bl2
  26. $0BA achr lr2   $0CD achr tb2   $0CB achr tm2   $0CA achr bm2
  27. $0CC achr lm2   $0B9 achr rm2   $0CE achr mm2
  28.  
  29. : .?lines       ( --- )
  30.                 2line @
  31.                 if      ." ="
  32.                 else    ." -"
  33.                 then    ;
  34.  
  35. : oneline       2line off window.left statusline at
  36.                 >rev .?lines >norm showcur ;
  37.  
  38. : twoline       2line on  window.left statusline at
  39.                 >rev .?lines >norm showcur ;
  40.  
  41. : ?12line       2line @ if twoline else oneline then ;
  42.  
  43. : ?pd           ( --- ) pendown @ ;
  44.  
  45. : ?grafchar     ( n1 --- f1 )
  46.                 screenchar + dup >r 0MAX
  47.                 linebuf + 1+ c@ $0B3 $0DA between r> 0=
  48.                 if      drop 0 then ;
  49.  
  50. : ?around       ( --- f1 )  0
  51. ( left )       -1 ?grafchar if 1 or then
  52. ( right)        1 ?grafchar if 2 or then
  53. ( up   )        curline 1 >
  54.                 if <suln> 0 ?grafchar if 4 or then <sdln> then
  55. ( down )        curline lastline <
  56.                 if <sdln> 0 ?grafchar if 8 or then <suln> then ;
  57.  
  58. \                0   1   2   3   4   5   6   7
  59. : chars         ( n1 --- )
  60.                 exec:
  61.                 tb1 tb1 tb1 tb1 lr1 br1 bl1 bm1
  62.                 lr1 tr1 tl1 tm1 lr1 rm1 lm1 mm1
  63.                 tb2 tb2 tb2 tb2 lr2 br2 bl2 bm2
  64.                 lr2 tr2 tl2 tm2 lr2 rm2 lm2 mm2 ;
  65.  
  66. : drchr         ( --- )
  67.                 ?around 15 and 2line @ if 16 + then chars ;
  68.  
  69. : ?drchr        ( --- )         \ redraw if already graphics
  70.                 0 ?grafchar     \ graphics char?
  71.                 if      drchr   \ re-draw it
  72.                 then    ;
  73.  
  74. : fixaround     ( --- ) \ check and adjust bordering chars.
  75.         screenchar      if      lchr ?drchr rchr then
  76.         curline 1 >     if      upln ?drchr dnln then
  77.         curline lastline <
  78.                         if      dnln ?drchr upln then
  79.         screenchar 1+ rmargin @ <
  80.                         if      rchr ?drchr lchr then showcur ;
  81.  
  82. : penup/down    ( --- )
  83.                 pendown @ 0= dup pendown ! >norm showcur
  84.                 if      drchr fixaround
  85.                         window.left statusline at >rev .?lines ." Pen DOWN"
  86.                 else    window.left statusline at >ul  .?lines ." Pen UP  "
  87.                 then    >norm showcur ;
  88.  
  89. : drawinit      ( --- )
  90.                 rmargin @ marginsave ! mxlln rmargin !
  91.                 pendown off penup/down window.left 8 + statusline at
  92.                 >ul ."  " >rev ."  ARROWS=draw, "
  93.       ." - 1line, = 2line, INS=PenUP/DOWN, DEL=clear, ESC=done."
  94.                 >ul edeeol >norm showcur ;
  95.  
  96. : clearchar     ( --- )
  97.                 false save!> imode
  98.                 bl schr
  99.                 restore> imode
  100.                 lchr fixaround ;
  101.  
  102. : goright       ( --- ) rchr ?pd if drchr fixaround then ;
  103.  
  104. : goleft        ( --- ) lchr ?pd if drchr fixaround then ;
  105.  
  106. : godown        ( --- ) dnln ?pd if drchr fixaround then ;
  107.  
  108. : goup          ( --- ) upln ?pd if drchr fixaround then ;
  109.  
  110. : lines         ( --- )         \ line drawing commands
  111.                 ?browse ?exit
  112.                 drawinit ?12line drchr fixaround
  113.         begin   showcur key dup 27 ( ESC) <>  over 193 ( F7) <> and
  114.                   \ while not   ESCAPE    and not  F7.
  115.         while       '-' over = if   drop oneline    ?drchr else
  116.                     '=' over = if   drop twoline    ?drchr else
  117.         211 over = over 8 = or if   drop clearchar         else
  118. ( pendown )         210 over = if   drop penup/down        else
  119. ( right )           205 over = if   drop goright           else
  120. ( left  )           203 over = if   drop goleft            else
  121. ( up    )           200 over = if   drop goup              else
  122. ( down  )           208 over = if   drop godown            else
  123.                 drop then then then then then then then then
  124.         repeat  drop marginsave @ rmargin ! ;
  125.  
  126. ' lines is drawlin
  127.  
  128. headers
  129.  
  130. forth definitions
  131.  
  132.  
  133.