home *** CD-ROM | disk | FTP | other *** search
/ GEMini Atari / GEMini_Atari_CD-ROM_Walnut_Creek_December_1993.iso / files / language / f68k / editor.exp < prev    next >
Encoding:
Text File  |  1993-10-23  |  11.6 KB  |  426 lines
  1. \                                                                  cep 21Apr91
  2.  
  3.  
  4.  
  5.  
  6.  
  7.  
  8.  
  9.  
  10.                             -->
  11.  
  12.  
  13.  
  14.  
  15.  
  16.  
  17.  
  18.  
  19.  
  20.  
  21.  
  22.  
  23.  
  24.  
  25.  
  26. -->    \\                                                          JPS 14-7-90
  27. Table of actions
  28.  
  29.     ^H makes bkspc           ^? makes help
  30.     ^E makes cur-up          ^X makes cur-down
  31.     ^S makes cur-left        ^D makes cur-right
  32.     ^G makes del-c           ^J makes >screen
  33.     ^M makes edicr           ^T makes ed-home
  34.     ^R makes reread          ^A makes \shadow
  35.     ^N makes nextscr         ^B makes lastscr
  36.     ^O makes c>stack         ^P makes c<stack
  37.     ^K makes l>stack         ^L makes l<stack
  38.     ^W makes /modus          ^Q makes cop>stack
  39.    esc makes flushed.exit    ^C makes canceled.exit
  40.     ^U makes ins-line        ^Y makes del-line
  41.     ^> makes load.exit       ^< makes #1.load
  42.     ^Z makes cop.l>stack     ^I makes ed-tab
  43.  
  44.  
  45.  
  46.  
  47.  
  48.  
  49.  
  50.  
  51. \                                                                 JPS 10-19-90
  52. Vocabulary Editor     also Editor definitions
  53.  
  54.  
  55. blk @ blockstream lastblock constant helpblock
  56. Editor
  57.  
  58. &2000 constant b/blk
  59. -1 Variable ins? ins? !    \ Einfügen/Überschreiben
  60. variable updated?   \ Screen geändert
  61. variable /find      \ Länge des Suchstrings
  62. variable taste      \ Zuletzt eingegebens Zeichen
  63. variable modified   \ wurde editiert?
  64. -1 Variable id?  id? !   \ ID schon eingegeben?
  65.  
  66. variable  pad*     \ Offest für Stack im PAD
  67. 0 pad* !
  68. : pad@ ( c --)   -1 pad* +! pad pad* @ + c@  ;
  69. : pad! ( -- c )   pad pad* @ + c!  1 pad* +! ;
  70.  
  71.  
  72.  
  73.  
  74.  
  75. -->
  76. \  full screen editor, cursor control                              JPS 7-14-90
  77. variable (row)     variable (col)
  78. variable (oldrow)  variable (oldcol)
  79. : ed-at ( row col -- )     2dup
  80.          (col) ! (row) !  swap at ;
  81. : row  (row) @ ;
  82. : col  (col) @ ;
  83.  
  84. : save_crsr
  85.         save_cursor  hide_cursor
  86.         row (oldrow) !   col (oldcol) ! ;
  87.  
  88. : restore_crsr
  89.         restore_cursor  show_cursor
  90.         (oldrow) @ (row) !  (oldcol) @ (col) ! ;
  91.  
  92.  
  93.  
  94.  
  95.  
  96.  
  97.  
  98.  
  99.  
  100. -->
  101. \ CURSOR                                                           JPS 7-14-90
  102.  
  103. : drin? ( row col -- row col f) 2dup swap
  104.                        0 &25 within  swap 0 &80 within  and ;
  105. : set-curs ( row col --)  drin? IF ed-at ELSE bell 2drop THEN ;
  106. : cur-up    ( --)         row 1- col set-curs ;
  107. : cur-right ( --)         row col 1+ set-curs ;
  108. : cur-left  ( --)         row col 1- set-curs ;
  109. : cur-down  ( --)         row 1+ col set-curs ;
  110. : ed-home      ( --)      0 0 ed-at ;
  111.  
  112. : edirow  ( -- n )        row ;
  113. : edicol  ( -- n )        col ;
  114. : ediAT   ( n1 n2 -- )    ed-at ;
  115.  
  116.  
  117. : clear-first-line ( -- ) &64 0 at &16 spaces &64 0 at ;
  118.  
  119. : line0-." ( -- )  postpone clear-first-line
  120.                    postpone reverse_video postpone ."
  121.                    postpone normal_video ;  immediate
  122.  
  123.  
  124.  
  125. -->
  126. \ BLOCK U. ZEILE ZEIGEN                                            cep 27Feb91
  127.  
  128. : ediblk ( -- adr)  scr @ block ; \ Adr des aktuellen Blocks
  129.  
  130. : show-line ( n --)   \ zeigt Zeile n d. aktuellen Screens
  131.                     save_crsr
  132.                     dup &80 * ediblk + swap
  133.                     0 ed-at &80 -trailing &80 min dup >r  type
  134.                     r> &80 < IF del_eol THEN   restore_crsr ;
  135.  
  136. : getblk ( n --)   updated? @ modified @ or  modified !
  137.                    0 updated? !
  138.                    dup  block drop   scr !
  139.                    &25 0 DO  i show-line  LOOP
  140.                    save_crsr line0-." Screen " scr @ . restore_crsr ;
  141.  
  142.  
  143.  
  144. : help ( -- ) save_crsr update  scr @
  145.               helpblock (block  page  &2000 0
  146.               DO cr i over + 80 -trailing type 80 +LOOP  key 2drop
  147.               getblk restore_crsr ;
  148.  
  149.  
  150. -->
  151. \ ADR. VON CURSOR U. ZEILE , ID                                    JPS 14-7-90
  152. : point ( -- adr)        \ adr des Zeichens beim Cursor
  153.                      ediblk edirow &80 * edicol + + ;
  154.  
  155. : lineadr (  -- adr )        \ adr der Cursorzeile
  156.                      edirow &80 * ediblk + ;
  157.  
  158. create  'id   18 allot
  159. : get-id ( --)   cr ." Enter your ID: "
  160.                   save_crsr ." .............." restore_crsr
  161.                   'id 4+ 14 expect
  162.                   span @ 'id !   0 id? ! ;
  163.  
  164. : put-id ( --)    'id @ ?dup 0> IF save_crsr
  165.                    0 &64 ediat  &14 0 DO bl point i + c! LOOP
  166.                    dup >r &78 swap - 0 swap ediat
  167.                   'id 4+ point r> cmove restore_crsr THEN ;
  168.  
  169.  
  170.  
  171.  
  172.  
  173.  
  174.  
  175. -->
  176. \ ZEILENREST VERSCHIEBEN                                           JPS 7-14-90
  177. : >schieben ( --)   \ schiebt Zeile ab Cursor nach rechts
  178.                    true updated? !
  179.                    point dup 1+
  180.                    &79 edicol dup >r - cmove>
  181.                    edirow r> ediat ;
  182.  
  183. : <schieben ( --)  \ schiebt Zeile ab Cursor nach links
  184.                    true updated? !
  185.                    point dup 1-
  186.                    &80 edicol dup >r - cmove
  187.                    edirow dup show-line r> ediat
  188.                    lineadr &79 + bl swap c! cur-left ;
  189.  
  190. : passt? ( -- f)  lineadr &79 + c@ bl = ;
  191.  
  192.  
  193.  
  194.  
  195.  
  196.  
  197.  
  198.  
  199.  
  200. -->
  201. \ ZEILEN EINFUEGEN                                                 JPS 7-14-90
  202.  
  203.  
  204. : leerzeile? ( -- f) ediblk &1920 + -1 &80 0 DO swap
  205.                          dup i + c@ bl = rot and LOOP nip ;
  206.  
  207. : edicr ( -- )         edirow 1+ dup &25 < IF 0 ediat   ELSE
  208.                                               bell drop THEN ;
  209.  
  210. : leer> ( --)  lineadr &80 bl fill ;     \ erzeugt Leerzeile
  211.  
  212. : >line ( n -- addr )   &80 * ediblk + ;
  213.  
  214. : ins-line ( --) \ fügt Leerzeile ein
  215.                 true updated? !
  216.                 leerzeile?
  217.                 IF lineadr dup &80 +
  218.                    &24 edirow - &80 * cmove>  leer>
  219.                    &25 edirow
  220.                    DO i show-line LOOP
  221.                 ELSE bell THEN ;
  222.  
  223.  
  224.  
  225. -->
  226. \  ZEILEN U. ZEICHEN LOESCHEN                                      JPS 14-7-90 0
  227. : del-line ( --)  \ löscht eine Zeile
  228.         true updated? !  save_crsr
  229.         lineadr dup &80 + swap
  230.         &24 edirow - &80 * cmove
  231.         &24 0 ediat leer> restore_crsr
  232.         &25 edirow DO i show-line LOOP ;
  233.  
  234. : del-c  ( --)       row col 1+ ed-at <schieben edirow show-line ;
  235.  
  236. : bkspc  ( --)       row col 1- drin? IF
  237.                        <schieben edirow show-line THEN 2drop ;
  238.  
  239. : /modus ( --)  ins? @ not ins? !   save_crsr
  240.                 ins? @ IF line0-."    insert"
  241.                 ELSE line0-." overwrite" THEN restore_crsr ;
  242.  
  243. : ed-tab ( -- )         4  col 4 mod -  0 ?DO cur-right LOOP ;
  244.  
  245.  
  246.  
  247.  
  248.  
  249.  
  250. -->
  251. \ EINFUEGEN,UEBERSCHREIBEN,VOR,ZURUECK,EXITS        JPS 16/10/8    JPS 14-7-90
  252. : overwr ( c -- )    true updated? !
  253.                       point c! cur-right edirow show-line ;
  254.  
  255. : ins ( c -- )       passt? IF >schieben point c! cur-right
  256.                       edirow show-line ELSE drop bell THEN ;
  257.  
  258. : ed-write ( -- )    taste @ $ff and dup bl 160 within
  259.                IF ins? @ IF ins ELSE overwr THEN ELSE drop THEN ;
  260.  
  261. : update? ( -- )       updated? @ IF update put-id THEN ;
  262.  
  263. : nextscr ( -- )       update?  scr @ 1+ getblk ;
  264.  
  265. : lastscr ( -- )       update?  scr @ 1- getblk ;
  266.  
  267. : save.scr ( -- )      updated? @ modified @ or
  268.                         IF save-buffers THEN ;
  269.  
  270.  
  271.  
  272.  
  273.  
  274.  
  275. -->
  276. \ UNDO, ZEILEN U. ZEICHEN ZUM PAD                   JPS 16/10/8    JPS 7-22-90
  277.  
  278. : reread ( -- )        scr @ -1 prev @ 4 + !   getblk ;
  279.  
  280. : load.exit ( -- f )  update? save.scr 0 &24 at cr scr @ load  -1 ;
  281.  
  282. : #1.load   ( -- F )  update? save.scr 0 &24 at cr  1 load      -1 ;
  283.  
  284. : c>stack ( -- )  point c@ pad! del-c ;
  285.  
  286. : c<stack ( -- )  passt? pad* @ 0 > and IF  >schieben pad@
  287.                     point c! edirow show-line ELSE bell THEN ;
  288.  
  289. : l>stack ( --)   lineadr pad pad* @ + &80 cmove
  290.                     &80 pad* +!    del-line ;
  291.  
  292. : l<stack ( -- )  pad* @ &79 > leerzeile? and IF ins-line
  293.                     pad pad* @ + &80 - lineadr &80 cmove
  294.                  edirow show-line -&80 pad* +! ELSE bell THEN ;
  295.  
  296. : cop>stack ( -- )   point c@ pad! cur-right ;
  297.  
  298. : cop.l>stack ( -- )   lineadr pad pad* @ +  &80 cmove
  299.                         &80 pad* +!  cur-down ;
  300. -->
  301. \ SHADOWSCREEN                                                      JPS 8-5-90 -
  302.  
  303. : \shadow ( -- ) ;
  304.       \  scr @ capacity @ 2/ 2dup < IF + ELSE - THEN getblk ;
  305.  
  306. : >screen ( -- )   save_crsr line0-." Screen: "
  307.                    pad pad* @ + dup 2dup 6 erase 1+ 4 expect
  308.                    span @ ?dup
  309.                    IF swap c!
  310.                       number? drop update?
  311.                    ELSE 2drop scr @ THEN restore_crsr getblk ;
  312.  
  313.  
  314. : flushed.exit ( -- f)   update? save.scr 0 &24 at cr
  315.                        ." Scr # " scr @ . ." flushed"   -1  ;
  316.  
  317. : canceled.exit  0 &24 at cr  ." Scr # " scr @ . ." canceled" -1 ;
  318.  
  319.  
  320.  
  321.  
  322.  
  323.  
  324.  
  325. -->
  326. \ FINDEN                                                           cep 28Feb91
  327. \ : get.string ( --)   save_crsr  line0-." String: "
  328. \                      pad pad* @ + 20 expect
  329. \                      span @ /find !  restore_crsr ;
  330. : pos-cur ( offset --)    &80 u/mod swap ediat ;
  331.  
  332.  
  333. \ : weiter? ( -- f )   save_crsr 0 10 /find @ + ed-at ." weiter?"
  334. \                      restore_crsr  key $7F and ascii j = ;
  335.  
  336. \ : find.str ( --)  get.string
  337. \        capacity @ scr @ 1+ DO pad pad* @ +
  338. \            /find @ i block b/blk search
  339. \            IF i getblk pos-cur weiter? IF ELSE LEAVE THEN
  340. \            ELSE  drop THEN
  341. \        LOOP  save_crsr 0 0 ed-at 70 spaces restore_crsr ;
  342.  
  343.  
  344.  
  345.  
  346.  
  347.  
  348.  
  349.  
  350. -->
  351. \ TASTENCODES                                                      JPS 7-14-90
  352.  
  353.  
  354.  
  355.   $7 constant ^G          $1E constant ^>
  356.  $13 constant ^S           $4 constant ^D
  357.   $5 constant ^E          $18 constant ^X
  358.   $9 constant ^I           $A constant ^J
  359.   $D constant ^M          $1B constant esc
  360.   $8 constant ^H          $1D constant ^=
  361.  $12 constant ^R          $11 constant ^Q
  362.  $19 constant ^Y          $14 constant ^T
  363.  $1F constant ^?           $E constant ^N
  364.   $2 constant ^B          $1C constant ^<
  365.   $F constant ^O          $10 constant ^P
  366.   $B constant ^K           $C constant ^L
  367.  $1A constant ^Z          $15 constant ^U
  368.  $17 constant ^W           $1 constant ^A
  369.  $03 constant ^C
  370.  
  371.  
  372.  
  373.  
  374.  
  375. -->
  376. \ Table of actions                                                 JPS 7-14-90
  377. : makes ( n --)  , ' , ;          \   n makes <name>
  378.  
  379. create  'funktionen
  380.     ^H makes bkspc           ^? makes help
  381.     ^E makes cur-up          ^X makes cur-down
  382.     ^S makes cur-left        ^D makes cur-right
  383.     ^G makes del-c           ^J makes >screen
  384.     ^M makes edicr           ^T makes ed-home
  385.     ^R makes reread          ^A makes \shadow
  386.     ^N makes nextscr         ^B makes lastscr
  387.     ^O makes c>stack         ^P makes c<stack
  388.     ^K makes l>stack         ^L makes l<stack
  389.     ^W makes /modus          ^Q makes cop>stack
  390.    esc makes flushed.exit    ^C makes canceled.exit
  391.     ^U makes ins-line        ^Y makes del-line
  392.     ^> makes load.exit       ^< makes #1.load
  393.     ^Z makes cop.l>stack     ^I makes ed-tab
  394.      0 makes ed-write  here 4- constant 'write
  395.  
  396.  
  397.  
  398.  
  399.  
  400. -->
  401. \ Für die Haupteingabeschleife                                     JPS 14-7-90
  402.  
  403. : edinit ( n -- n )  0 modified !
  404.     id? @ IF get-id THEN
  405.     page  nowrap
  406.     getblk  clearstack
  407.     r# @ pos-cur ;
  408.  
  409. : ed-key ( -- scancode )
  410.         key $ff and ;
  411.  
  412. also FORTH definitions
  413. : l ( n --)  edinit
  414.         BEGIN
  415.            ed-key dup taste ! 'write swap    ( 'write taste )
  416.            'write 'funktionen  DO
  417.                dup i @ =                      \ Vergleich mit Tast.Code
  418.                  IF  nip i 4+ swap LEAVE THEN
  419.             8 +LOOP
  420.             drop @ execute  row col ed-at  depth IF ELSE 0 THEN
  421.         UNTIL  0 25 at cr ;
  422.  
  423. : v ( --)     scr @ l ;
  424.  
  425. toss toss FORTH
  426.