home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / compiler / fpc / source / sedchars.seq < prev    next >
Text File  |  1989-09-26  |  4KB  |  112 lines
  1. \ SEDCHARS.SEQ  Extended character set insertion for SED
  2.  
  3. forth definitions
  4.  
  5. defer charbutton ' noop is charbutton
  6.  
  7. 59 value charcol
  8. 01 value charline
  9.  0 value chcol
  10.  0 value chrow
  11.  
  12. XHERE PARAGRAPH + DUP XDPSEG ! XSEG @ - XDP OFF
  13. value extcharseg ( --- seg-rel )
  14. 0               x,"           " 1+
  15.         xdp @   x,"                 " 10 extcharseg +xseg rot 6 + c!L  1+
  16.                 x,"          " 1+
  17.                 x,"          " 1+
  18.                 x,"  Ç ü é â ä à å ç " 1+
  19.                 x,"  ê ë è ï î ì Ä Å " 1+
  20.                 x,"  É æ Æ ô ö ò û ù " 1+
  21.                 x,"  ÿ Ö Ü ¢ £ ¥ ₧ ƒ " 1+
  22.                 x,"  á í ó ú ñ Ñ ª º " 1+
  23.                 x,"  ¿ ⌐ ¬ ½ ¼ ¡ « » " 1+
  24.                 x,"  ░ ▒ ▓ │ ┤ ╡ ╢ ╖ " 1+
  25.                 x,"  ╕ ╣ ║ ╗ ╝ ╜ ╛ ┐ " 1+
  26.                 x,"  └ ┴ ┬ ├ ─ ┼ ╞ ╟ " 1+
  27.                 x,"  ╚ ╔ ╩ ╦ ╠ ═ ╬ ╧ " 1+
  28.                 x,"  ╨ ╤ ╥ ╙ ╘ ╒ ╓ ╫ " 1+
  29.                 x,"  ╪ ┘ ┌ █ ▄ ▌ ▐ ▀ " 1+
  30.                 x,"  α ß Γ π Σ σ µ τ " 1+
  31.                 x,"  Φ Θ Ω δ ∞ φ ε ∩ " 1+
  32.                 x,"  ≡ ± ≥ ≤ ⌠ ⌡ ÷ ≈ " 1+
  33.                 x,"  ° ∙ · √ ⁿ ² ■   " 1+
  34. constant extrows
  35.  
  36. : extchar@      ( --- c1 )
  37.                 extcharseg +xseg 0 chrow 0
  38.                 ?do     2dup c@L + 1+
  39.                 loop    1+ chcol 2* + 1+ c@L ;
  40.  
  41. headerless
  42.  
  43.                                 \ f1 is true if operation was not canceled
  44. : graphicchar   ( --- <c1> f1 ) \ c1 present if f1 is true
  45.                 get-cursor >r
  46.                 ?doingmac 0=    \ if we are performing a macro, don't show
  47.                                 \ the character box in screen, we don't
  48.                                 \ want to see it anyway, and it slows things
  49.                                 \ down too much.
  50.                 dup>r
  51.                 if      savescr
  52.                         big-cursor
  53.                         save> attrib >norm
  54.                         charcol charline
  55.                         charcol extcharseg +xseg 0 c@L
  56.                         + 1+ charline extrows 2+ + box
  57.                         tx 1+ ty extrows 1+ + at ."       ESC=Cancel "
  58.                         extcharseg +xseg 0 extrows 1+ 1
  59.                         do      tx 1+ ty i + at
  60.                                 2dup c@L 1 0 d+ 3dup typeL +
  61.                         loop    2drop
  62.                         restore> attrib
  63.                 then
  64.                 ['] charbutton save!> dobutton
  65.                 begin   r@ \ if not doing a macro display value
  66.                         if      tx 1+ ty extrows 1+ + at extchar@ 4 .r
  67.                                 tx 2+ chcol 2* + ty 1+ chrow + at
  68.                         then
  69.                         key dup 13 <> over 27 <> and
  70.                 while   ( c1 --- )
  71.                         case
  72. ( Up Arrow )                200 of  chrow 1-            0max =: chrow endof
  73. ( Dn Arrow )                208 of  chrow 1+  extrows 1- min =: chrow endof
  74. ( Rt Arrow )                205 of  chcol 1+           7 min =: chcol endof
  75. ( Lt Arrow )                203 of  chcol 1-            0max =: chcol endof
  76. ( PgDn )                    209 of  chrow 5 + extrows 1- min =: chrow endof
  77. ( PgUp )                    201 of  chrow 5 -           0max =: chrow endof
  78. ( Home )                    199 of                         0 =: chcol endof
  79. ( End )                     207 of                         7 =: chcol endof
  80.                                 drop
  81.                         endcase
  82.                 repeat
  83.                 restore> dobutton
  84.                 r>      \ doing macro flag
  85.                 if      restscr
  86.                 then    13 = dup
  87.                 if      extchar@ swap
  88.                 then    r> set-cursor ;
  89.  
  90. ' graphicchar is graphchar
  91.  
  92. \ Link the graphics character selector into editor assuming the editor
  93. \ has been loaded, otherwise we are done.
  94.  
  95. headers
  96.  
  97. defined editor nip #if          \ load only if EDITOR exists
  98.  
  99. : sedchar       ( --- )
  100.                 ?browse ?exit
  101.                 graphicchar
  102.                 if      schr
  103.                 then    scrshow ?cursor ;
  104.  
  105. ' sedchar is insany
  106.  
  107. #endif
  108.  
  109. forth definitions
  110.  
  111.  
  112.