home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / compiler / fpc / source / therctxt.seq < prev    next >
Text File  |  1990-03-28  |  2KB  |  84 lines
  1. \\ THERCTXT.SEQ     Hercules graphics mode text routines 
  2.  
  3.     Hercules graphics mode text support, originally by Wempe, subsequently
  4.     modified by Oliver Shank, Mike Mayo, Tom Zimmer and Jerry Modrow.
  5.  
  6.     This is a simple two color system, color zero being black, and color
  7.     one being white. If you set a color above 127, a point will be drawn
  8.     XOR'd with the current pixel.
  9.  
  10. {
  11.  
  12.  
  13. \ FORTH DECIMAL   \ TARGET    \ Source Library
  14.  
  15.  
  16. $0F000 value charseg
  17. $0FA6E value chartbl
  18. 0      value charadr
  19. 0      value hercX
  20. 0      value hercY
  21.  
  22.  
  23. : H-AT ( x y -- ) \ AT for Hercules
  24.         =: hercY  =: hercX  ;
  25.  
  26.  
  27. : HERC-AT ( x y -- ) \ AT for Hercules
  28.         8 * =: hercY  8 * =: hercX  ;
  29.  
  30.  
  31. : HERC-AT? ( -- x y ) \ AT? for Hercules
  32.         hercX 8 *  hercY 8 * ;
  33.  
  34.  
  35. : (HERC-EMIT) ( c -- ) \ emit to Hercules graphics screen.
  36.         8 * chartbl +  =: charadr
  37.         hercX 8 /
  38.         hercY 4 /mod 90 *  swap $2000 * +
  39.         +  ( video-byte-addr )
  40.  
  41. \ POINTOFFSET       = INT[ROW/4] * 90 + REM[ROW/4]*$2000 + INT[COL/8]
  42. \ PIXEL(1 BIT)ADDR  = REM[COL/8] {WITHIN BYTE}
  43. \ Next bit, step along byte and to next byte.
  44. \ Next row, add $2000, and add 90 when wrapping.
  45.  
  46.         8 0 do  charseg charadr c@l  incr> charadr
  47.                 over herc-seg @ swap c!l
  48.                 $2000 +  dup $7FFF u> if 90 + then  $7FFF and
  49.           loop
  50.         drop
  51.         hercX 8 + 720 /mod  if 8 +!> hercY then  =: hercX  ;
  52.  
  53.  
  54. : (HERC-CR)  ( -- )       hercY 8 +  319 min  =: hercY   off> hercX  ;
  55. : HERC-EMIT  ( c -- )     printing @ IF pemit  ELSE (herc-emit)  THEN  ;
  56. : HERC-TYPEL ( s a l -- ) bounds ?do  dup i c@L emit  loop  drop ;
  57. : HERC-TYPE  ( a l -- )   bounds ?do  i c@ emit  loop  ;
  58. : HERC-CR    ( -- )       printing @ IF crlf   ELSE (herc-cr)  THEN  ;
  59.  
  60.  
  61. : HERCULES$      ( -- )
  62.         HERCULES                \ Hercules graphics mode
  63. \       ['] herc-typeL is typeL
  64.         ['] herc-type  is type  \ vector for graphics mode text
  65.         ['] herc-emit  is emit
  66.         ['] herc-at    is at
  67.         ['] herc-at?   is at?
  68.         ['] herc-cr    is cr    ;
  69.  
  70.  
  71. : HTEXT$         ( -- )
  72.         HTEXT               \ Text mode
  73. \       ['] QtypeL is typeL
  74.         ['] (type) is type  \ restore normal text words
  75.         ['] (emit) is emit
  76.         ['] ibm-at is at
  77.         ['] ibm-at? is at?
  78.         ['] crlf is cr
  79.         DARK  ;
  80.  
  81. \ FORTH TARGET >TARGET
  82. }
  83.  
  84.