home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / CLIPPER / MISC / FFA.ZIP / PRINTING.SEQ < prev    next >
Encoding:
Text File  |  1988-01-04  |  13.8 KB  |  380 lines
  1. \ PRINTING.SEQ  Export & Import for SED.           by 1987 Tom Zimmer
  2.  
  3. only forth also hidden also editor also definitions
  4.  
  5. variable dolst  dolst off
  6.  
  7. : p$type        ( a1 --- )      \ print string at address
  8.                 count over + swap
  9.                 ?do     i c@ pemit
  10.                 loop    ;
  11.  
  12. : pcr           ( --- ) 13 pemit 10 pemit #out off ;
  13.  
  14. : ptype         ( a1 n1 --- ) bounds
  15.                 ?do i c@ pemit
  16.                 loop    ;
  17.  
  18. : .p##          ( N1 --- )      \ Print two low digits of n1.
  19.                 0 <# # # #> pTYPE ;
  20.  
  21. : <.pTIME>       BASE @ >R DECIMAL SWAP 0 256 UM/MOD .p## " :" ptype .p##
  22.                              " :" ptype 0 256 UM/MOD .p## drop
  23.                                                         \ " ." ptype .p##
  24.                 R> BASE ! ;
  25.  
  26. : <.pDATE>       ( D1 --- )
  27.                 BASE @ >R DECIMAL
  28.                 0 256 UM/MOD .p## " /" ptype .p## " /" ptype 1900 - .p##
  29.                 R> BASE ! blnks 3 ptype ;
  30.  
  31. : pdate/time    GETDATE <.pdate> gettime <.ptime> ;
  32.  
  33. variable controlines    \ number of control line encountered.
  34.  
  35. : skipto        ( a1 --- a2 )   \ skips all but one leading bl
  36.                 1+
  37.                 begin   dup c@ bl =
  38.                 while   1+
  39.                 repeat  1- ;
  40.  
  41. : ?escprint     ( --- f1 )
  42.                 linebuf 1+ dup c@ ascii . =
  43.                 swap 1+ c@ ascii # = and dup
  44.                 if      linebuf 3 +     controlines incr
  45.                         begin   skipto dup 1+ c@
  46.                                 ascii 0 ascii 9 between
  47.                         while   0.0 rot convert nip swap
  48.                                 255 min pemit
  49.                         repeat  drop
  50.                 then    ;
  51.  
  52. : .noprinter    ( --- )
  53.                 dolst @ 0=
  54.                 if      0 statusline at blnks 18 type
  55.                 else    cr
  56.                 then    " *** Printer OFF LINE, or NOT connected. ***"
  57.                 type eeol beep
  58.                 dolst @ 0=
  59.                 if showcur 2 seconds emptykbd scrshow then ;
  60.  
  61. : printline     ( --- ) ?escprint ?exit
  62.                 blnks lmargin @ ptype
  63.                 stripbl's linebuf count ptype
  64.                 pcr getline ;
  65.  
  66. variable pagenumber     1 pagenumber !
  67. variable firstpage      1 firstpage  !
  68. variable lastpage      99 lastpage   !
  69.  
  70. : .underline    ( --- )         \ underline current line.
  71.                 13 pemit #out off
  72.                 78 0
  73.                 do      ascii _ pemit
  74.                 loop    pcr pcr ;
  75.  
  76. : .pg#          ( --- )
  77.                 pagenumber @
  78.                 if      .underline
  79.                         " Page " ptype
  80.                         pagenumber @ 0 <# #s #> ptype "  of " ptype
  81.                         pagenumber incr
  82.                         lastpage @ 0 <# #s #> ptype "  Pages" ptype
  83.                         blnks 10 ptype
  84.                         pdate/time
  85.                         blnks 78 shndl @ c@ - #out @ - ptype
  86.                         shndl @ p$type
  87.                 then    ;
  88.  
  89. : newpage       ( --- )
  90.                 formfeed pemit ;
  91.  
  92. : setpage       firstpage @ pagenumber ! ;
  93.  
  94. : linesleft     ( --- )         \ lines left to print on page
  95.                 curline controlines @ 1- 0 max - 0 max
  96.                 prtlines mod ;
  97.  
  98. : .header       ( --- ) \ print first line of the current file
  99.                 pcr pcr
  100.                 0 #lineinfo ?cs: pad rot dup >r cmovel
  101.                 blnks lmargin @ ptype pad r> ptype
  102.                 .underline ;
  103.  
  104. : ?newpage      ( --- )
  105.                 linesleft 0=
  106.                 if      .pg# newpage .header
  107.                 then    ;
  108.  
  109. variable copies 1 copies !
  110.  
  111. variable pgtoprint      1 pgtoprint !
  112.  
  113. : todocpage     ( --- )
  114.                 pgtoprint @ 1- 0 max 199 min prtlines *
  115.                 to.line first.textline =: screenline
  116.                 dolst @ 0=
  117.                 if      scrshow
  118.                 then    ;
  119.  
  120. variable lsttoprint      99 lsttoprint !
  121.  
  122. : ?lastppg      ( --- f1 )
  123.                 lsttoprint @ 199 min prtlines * 2-
  124.                 curline < ;
  125.  
  126. : setlastpg     ( --- )
  127.                 lastline @ prtlines /mod swap
  128.                 if      1+ then dup lsttoprint ! lastpage ! ;
  129.  
  130. : doprint       ( --- )
  131.                 ?printer.ready 0= if  .noprinter exit then
  132.                 copies @ 0
  133.         ?do     <shom>  dolst @ 0=
  134.                 if      scrshow
  135.                 then    .header
  136.                 todocpage setpage controlines off
  137.                 begin   curline 0=
  138.                         if      pcr
  139.                         else    printline  then
  140.                         ?lastline 0= key? 0= and
  141.                         ?lastppg 0= and
  142.                 while   dolst @ 0=
  143.                 if      dnln
  144.                 else    <sdln>
  145.                 then    ?newpage
  146.                 repeat  prtlines linesleft - 1- 0 max
  147.                 0 ?do      pcr loop
  148.                 .pg# newpage    key? ?leave
  149.         loop    <shom>  dolst @ 0=
  150.                 if      scrshow emptykbd
  151.                 then    ;
  152.  
  153. : insertsector  ( --- f1 )      \ f1=true if end of file
  154.                 0 temp2.buf 128 over + swap
  155.                 do      i c@ 26 = i c@ 0= or
  156.                         if      drop true leave then
  157.                         i c@ dup 10 <>          \ ignore LnFeed
  158.                         if      dup 13 =        \ <CR> ins Line
  159.                                 if      drop nln
  160.                                 else    schr    \ insert char
  161.                                 then
  162.                         else    drop    then
  163.                 loop    ;
  164.  
  165. : imp/exp.init  ( --- )
  166.                 " TEMP.SEQ" ">$ shndl+ $>handle ;
  167.  
  168. : getinpfile    ( --- f1 )
  169.                 imp/exp.init
  170.                 ?shiftkey dup >rev
  171.                 if      drop
  172.                         ."  Select File from window to Import...Esc to Cancel"
  173.                         eeol >norm
  174.                         ['] qemit  is emit  getfile 0=  showstat
  175.                         ['] (emit) is emit  if true exit then
  176.                         shndl+ $>handle false
  177.                 else    ."  Importing from " shndl+ count type
  178.                         eeol >norm 3 tenths     \ a small delay
  179.                 then    ;
  180.  
  181.  
  182. : ?getexpfile   ( --- f1 )
  183.                 imp/exp.init
  184.                 ?shiftkey dup
  185.                 if      drop " Export Filename -->"
  186.                         first.textline inputline !
  187.                         input$ dup c@ 0= escflg @ or 0=
  188.                         if      shndl+ $>handle shndl+ pathset
  189.                                 " Can't read path" ?terror true
  190.                         else    drop false
  191.                         then    0= scrshow
  192.                 then    ;
  193.  
  194. : export        ( --- )
  195.                 markline @ dup 0< swap curline > or
  196.                 if      beep exit
  197.                 then    ?getexpfile ?exit
  198.                 0 statusline at ." Copying text..." eeol
  199.                 sdln                            \ move down a line in file
  200.                 shndl+ dup >r hcreate 0=
  201.                 if      0.0 r@ movepointer
  202.                         temp.buf 10 26 fill
  203.                         ?cs: temp.buf curline 1- #lineinfo + 10 cmovel
  204.                         markline @ #lineinfo drop nip
  205.                         curline 1- #lineinfo + nip over - 1+    \ +1 = ^Z
  206.                         r@ tsegb @ exhwrite drop
  207.                         r@ hclose drop ." ..Done "
  208.                 else    ." Failed " beep 1 seconds
  209.                 then    r> drop eeol suln 2 tenths ;
  210.  
  211. ' export is exportx     \ patch into smaller editor
  212.  
  213. : excut         ( --- )         \ Cut out marked text
  214.                 markline @ dup 0< swap curline > or
  215.                 if      beep exit
  216.                 then    ?getexpfile ?exit
  217.                 0 statusline at ." Cutting text..." eeol
  218.                 sdln                            \ move down a line in file
  219.                 shndl+ dup >r hcreate 0=
  220.                 if      0.0 r@ movepointer
  221.                         temp.buf 10 26 fill
  222.                         ?cs: temp.buf curline 1- #lineinfo + 10 cmovel
  223.                         markline @ #lineinfo drop nip
  224.                         curline 1- #lineinfo + nip over - 1+    \ +1 = ^Z
  225.                         r@ tsegb @ exhwrite drop
  226.                         r@ hclose drop ." ..Done "
  227.                         curline markline @ - 0 max 0 2dup >
  228.                         if      markline @ backto.line
  229.                                 ?do     <ldel>  \ Delete current line
  230.                                 loop    scrshow
  231.                         else    2drop
  232.                         then
  233.                 else    ." Failed " beep 2 seconds
  234.                 then    r> drop eeol suln sdln 2 tenths ;
  235.  
  236. ' excut is excutx       \ patch into smaller editor
  237.  
  238. : import        ( --- )
  239.                 0 statusline at ." Inserting text..." eeol 2 tenths
  240.                 getinpfile ?exit
  241.                 imode dup @ >r on
  242.                 shndl+  dup >r hopen 0=
  243.                 if      0.0 r@ movepointer
  244.                         begin   temp2.buf 128 r@ hread 128 <
  245.                                 insertsector or showstat
  246.                                 key? if key 27 = or then
  247.                         until   r@ hclose drop
  248.                 then    r> drop
  249.                 r> imode ! emptykbd ;
  250.  
  251. ' import is importx     \ patch into smaller editor
  252.  
  253. defer escattrib ' >rev is escattrib
  254.  
  255. : torev         ['] >rev     is escattrib ;
  256. : toblnk        ['] >revblnk is escattrib ;
  257.  
  258. 5 constant pitems
  259.  
  260. create prtmenu pitems c,
  261.         28 ,   8 ,  ," First Page to print"      pgtoprint ,
  262.         28 ,  10 ,  ," Last  Page to print"     lsttoprint ,
  263.         28 ,  12 ,  ," Left margin indent"       lmargin   ,
  264.         65 ,   8 ,  ," Start numbering pages at" firstpage ,
  265.         65 ,  10 ,  ," Copies to print"          copies    ,
  266.  
  267. : showpdata     ( --- )
  268.                 >rev    prtmenu count 0
  269.                 do      dup 2@ swap at
  270.                         4 + count + dup @ @ 5 .l 2+
  271.                 loop    drop >norm ;
  272.  
  273. : showcmds      ( --- )
  274.                 14 16 at  >bold ." Press "             escattrib
  275.                 ."  ESC " >bold ."  to cancel, or "    escattrib
  276.                 ."  P "   >bold ."  to start printing" >norm ;
  277.  
  278. : showpform     ( --- ) dark
  279.                 25 1 at >rev  ."  Printing Setup Menu " >norm
  280.                 15 3 at >bold ." Use Enter or Arrows to move between fields"
  281.                 22 5 at ." Use + or - to change values" >norm
  282.                 prtmenu count 0
  283.                 do      dup 2@ 2 pick 4 + c@ - 1- swap at
  284.                         4 + count 2dup type + 2+
  285.                 loop    drop 64 7 at ." 0=no #'s" showcmds ;
  286.  
  287. : sc            ( --- )
  288.                 torev showcmds ;
  289.  
  290. variable pitem  variable pnumval
  291.  
  292. : >pitem        ( --- a1 )
  293.                 prtmenu 1+ pitem @ 0
  294.                 ?do     4 + count + 2+
  295.                 loop    ;
  296.  
  297. : showpcur      ( --- )
  298.                 >pitem 2@ 6 + swap at ;
  299.  
  300. : ptohome       pitem off pnumval off torev showpcur ;
  301.  
  302. : penter        ( c1 --- c1 ) dup 13 =  \ Enter key
  303.                 over 208 = or            \ down arrow
  304.                 if      pitem @ 1+ pitems mod pitem ! sc
  305.                         showpcur pnumval off drop 0
  306.                 then    ;
  307.  
  308. : pincr         ( c1 --- c1 ) dup 43 =  \ plus "+" sign
  309.                 if      >pitem  4 + count + @
  310.                          pitem  @ pitems 1- =
  311.                         if      dup @ 0= swap !
  312.                         else    incr
  313.                         then    showpdata sc showpcur drop 0
  314.                 then    ;
  315.  
  316. : pdecr         ( c1 --- c1 )
  317.                 dup 45 =        \ minus "-" sign
  318.                 if      >pitem  4 + count + @
  319.                         dup @ 1- 0 max swap !
  320.                         showpdata sc showpcur drop 0
  321.                 then    ;
  322.  
  323. : prright       ( c1 --- c1 )
  324.                 dup 203 =        \ left arrow
  325.                 over 205 = or     \ right arrow
  326.                 if      pitem @ 3 + pitems mod pitem ! sc
  327.                         showpcur pnumval off drop 0
  328.                 then    ;
  329.  
  330. : prup          ( c1 --- c1 )
  331.                 dup 200 =         \ up arrow
  332.                 if      pitem @ 5 + pitems mod pitem ! sc
  333.                         showpcur pnumval off drop 0
  334.                 then    ;
  335.  
  336. : pbkspace      ( c1 --- c1 )
  337.                 dup 8 =           \ back space
  338.                 if      pnumval off
  339.                         >pitem  4 + count + @ off
  340.                         showpdata sc showpcur drop 0
  341.                 then    ;
  342.  
  343. : pnum          ( c1 --- c1 )           \ number between 0 and 9
  344.                 dup ascii 0 >= over ascii 9 <= and
  345.                 if      dup ascii 0 - pnumval @ 10 * + 199 min
  346.                         dup pnumval ! >pitem 4 + count + @ !
  347.                         showpdata sc showpcur drop 0
  348.                 then    ;
  349.  
  350. : pmenu         ( --- )         \ print menu
  351.                 setlastpg
  352.                 showpform  showpdata ptohome
  353.                 begin   key dup 27 <>     over
  354. ( Alt-P )                      153 <> and over bl or
  355.                            ascii p <> and
  356.                 while   penter  pincr  pdecr  pnum  pbkspace
  357.                         prright prup
  358.                         if toblnk showcmds torev beep showpcur
  359.                         then
  360.                 repeat  showscreen bl or ascii p =
  361.                 if      doprint then    ;
  362.  
  363. ' pmenu is pmenux
  364.  
  365.                 \ IDS printer initialization, sets printer for
  366.                 \ black & while printer ribbon.
  367.  
  368. : elisting       ( --- )
  369.                 [ editor ]
  370.                 read.openfile
  371.                 sinit setlastpg
  372.                 cr ." Printing..."
  373.                 #out @ #line @ >r >r
  374.                 dolst on doprint dolst off
  375.                 r> r> at ;
  376.  
  377. only forth definitions
  378.  
  379.  
  380.