home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / compiler / fpc / source / seditwp.seq < prev    next >
Text File  |  1991-02-13  |  7KB  |  166 lines
  1. \ SEDITWP.SEQ   SED wordprocessor functions             by Tom Zimmer
  2.  
  3. editor definitions
  4.  
  5. headerless
  6.  
  7. \ Sub functions used by word wrap.
  8.  
  9. : split.lineend ( --- )
  10.                 wrap.buf linebuf.len blank
  11.                 rmargin @ 1- =: screenchar <<space>
  12.                 if      space> screenchar 1- 0MAX =: screenchar
  13.                 then    screenchar 1+ lmrgn 1+ max
  14.                 dup>r =: screenchar
  15.                 linebuf screenchar linelen over - 0MAX >r +
  16.                 1+ dup wrap.buf 1+ r@ cmove
  17.                 r@ wrap.buf c!
  18.                 r> blank modified
  19.                 putline getline wrapped 0=
  20.                 if      wrap.buf c@ =: wraplen
  21.                         on> wrapped r@ =: wraploc
  22.                 then    r>drop ;
  23.  
  24. : prepend.split ( --- )
  25.                 linebuf 1+ rmargin @ bl skip 0=
  26.                 wrap.buf c@ rmargin @ > or
  27.         if      drop linebuf 1+ lmrgn +
  28.                 off> screenchar <nln> off> screenchar
  29.         else    wrap.buf c@ 1+ >r linebuf 1+ dup r@ +
  30.                 linelen 1+ r@ + ch/l min r@ - cmove>
  31.                 linebuf 1+ r> blank
  32.         then    ch/l linebuf c! dup linebuf 1+ -
  33.                 @> rmargin 2 - min =: lmrgn
  34.                 >r wrap.buf count r@ swap cmove
  35.                 wrap.buf c@ 1+ +!> linelen
  36.                 wrap.buf c@ r> linebuf 1+ - + =: screenchar
  37.                 modified putline getline ;
  38.  
  39. \ main function for word wrap.
  40. \ You must set the right margin before this function will work.
  41.  
  42. : ?wrapfunc     ( --- )         \ conditionally split line
  43.                 ?browse ?exit
  44.                 off> wraploc off> wrapped off> wraplen
  45.                 linelen @> rmargin < ?exit              \ should we bother?
  46.                 ?full ?maxlines or ?exit                \ are we full?
  47.                 begin   linebuf linelen + c@ bl =       \ strip trailing BL's
  48.                 while   linelen 1- 0MAX =: linelen
  49.                 repeat
  50.                 linelen screenchar 1+ max =: linelen    \ at least to cursor
  51.                 linelen @> rmargin < ?exit              \ should we bother?
  52.                 screenline curline screenchar
  53.                 begin   linelen rmargin @ >=    \ line too long?
  54.                         ?full 0= and
  55.                 while   ?addline split.lineend
  56.                         ?addline <sdln>  prepend.split
  57.                 repeat  =: screenchar dup curline <>
  58.                 if      backto.line
  59.                         <sdln> incr> screenline suln
  60.                 else    drop
  61.                 then    =: screenline   ;
  62.  
  63. ' ?wrapfunc is ?wrap
  64.  
  65. \ Sub functions for paragraph justification
  66.  
  67. variable leadblnks
  68.  
  69. : ?getword      ( --- f1 )
  70.                 rmargin @ linelen 1+ - 0MAX <sdln>
  71.                 linebuf 1+ rmargin @ bl skip rmargin @ over -
  72.                 leadblnks ! 2dup bl scan bl wrap.buf 1+ c!
  73.                 nip - swap over wrap.buf 2+ swap cmove
  74.                 1+ dup wrap.buf c! > wrap.buf c@ 1 > and
  75.                 ?full 0= and ;
  76.  
  77. : getword       ( --- ) screenchar >r
  78.                 leadblnks @ =: screenchar
  79.                 modified del<>bl's delbl's <suln>
  80.                 wrap.buf count linebuf 1+ linelen + swap cmove
  81.                 wrap.buf c@ +!> linelen r> =: screenchar
  82.                 modified ;
  83.  
  84. : ?delline      ( --- )
  85.                 ?lastline ?exit
  86.                 curline 1+ #lineseg 0 c@l 2 =
  87.                 if      <sdln> <ldel> <suln>
  88.                 then    ;
  89.  
  90. : fillline      ( --- )
  91.                 begin   ?getword
  92.                 while   getword ?delline
  93.                 repeat  ;
  94.  
  95. \ Main function for paragraph justification.
  96.  
  97. : justify       ( --- )
  98.                 ?browse ?exit
  99.                 rmargin @ 131 >
  100.                 if      savescr cursor-off
  101.                         17 6 62 11 box&fill
  102.                         ."  You must set the right margin to a value" bcr
  103.                         ."  less than 132 before using justification."
  104.                         bcr bcr
  105.                         ."   \r ** Use Alt-S Setup ** \0    Press a \r KEY "
  106.                         beep key drop
  107.                         restscr cursor-on showcur
  108.                 else    ?full ?maxlines or curline #lineseg 0 c@l 2 = or
  109.                         if      sdln off> screenchar exit
  110.                         then    true save!> imode
  111.                         begin   linelen 0> ?lastline 0= and
  112.                                 ?full 0= and
  113.                         while   ?wrap fillline
  114.                                 incr> screenline clipdown scrshow
  115.                         repeat  begin   linelen 0= ?lastline 0= and
  116.                                 while   <sdln>
  117.                                 repeat  off> screenchar  off> lmrgn
  118.                         last.textline first.textline - 2/ curline min
  119.                         first.textline + =: screenline clipdown
  120.                         restore> imode emptykbd scrshow ?showfull drop
  121.                 then    ;
  122.  
  123. ' justify is jstfy
  124.  
  125. : rmset         ( --- )         \ set right margin to current column
  126.                 20  6 60 12 box&fill
  127.                 bcr ."  Right margin currently at column " rmargin @ 3 .r
  128.                 bcr
  129.                 bcr
  130.                 ."  Set right margin to column "
  131.                 on> filtering
  132.                 49 10 at tib 6 expect  span @ #tib ! >in off
  133.                 off> filtering
  134.                 22  8 at >rev
  135.                 bl word  dup c@ 0> >r number? r> and
  136.                 if      drop 10 max 132 min dup rmargin ! dup =: ermargin
  137.                         ."  Right margin set to column " 3 .r 5 spaces
  138.                 else    2drop ."   ** Right margin NOT changed. **   "
  139.                 then    >norm cursor-off 3 tenths scrshow ;
  140.  
  141. : sedsetup      ( --- )         \ setup function for SED
  142.                 savescr cursor-off
  143.                 ['] noop save!> dobutton
  144.                 16  6 66 12 box&fill
  145.                 ."  Setup options..\s15\r ESC \0 = cancel"
  146.                 bcr bcr
  147.                 ."  \r R \0 - set Right margin \r W \0 - adjust Window size"
  148.                 bcr bcr
  149.                 ." \s14\r Z \0 - Zoom Window"
  150.                 key bl or >r
  151.                 restscr cursor-on showcur
  152.                 'r' r@ = if rmset           then
  153.                 'w' r@ = if adjwind         then
  154.                 'z' r@ = if zoomwind        then
  155.                 r>drop
  156.                 restore> dobutton
  157.                 scrshow showstat cursor-on ;
  158.  
  159. ' sedsetup is sedset
  160.  
  161. headers
  162.  
  163. forth definitions
  164.  
  165.  
  166.