home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / compiler / fpc / source / herc.seq < prev    next >
Encoding:
Text File  |  1990-03-15  |  6.2 KB  |  223 lines
  1. \\ HERC.SEQ     Hercules point plotting routines by Wempe
  2.  
  3.   Hercules graphics support, originally by Wempe, subsequently
  4. modified by Oliver Shank, Mike Mayo, and Tom Zimmer.
  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   anew herc-words
  14.  
  15.  
  16. 0 VALUE VDOTS       \ verticle dots in screen
  17. 0 VALUE HDOTS       \ horizontal dots in screen
  18. 0 VALUE #COLORS     \ # of colors in current graphics mode
  19. 0 VALUE VID.SEG     \ video buffer segment address
  20. 0 VALUE VID.SIZE    \ video buffer size
  21.  
  22. VARIABLE COLOR      \ color of the DOT
  23.  
  24. VARIABLE HERC-SEG   \ segment for Hercules video buffer
  25.  
  26.  
  27. create GTBL
  28.         $35 c, $2D c, $2E c, $07 c, $5B c, $02 c,
  29.         $57 c, $57 c, $02 c, $03 c, $00 c, $00 c,
  30.  
  31.  
  32. create TTBL
  33.         $61 c, $50 c, $52 c, $0F c, $19 c, $06 c,
  34.         $19 c, $19 c, $02 c, $0D c, $0B c, $0C c,
  35.  
  36.  
  37. create BIT-MASKS
  38.         $7F c, $BF c, $DF c, $EF c, $F7 c, $FB c, $FD c, $FE c,
  39.  
  40.  
  41. : SET-HMODE     ( tbl -- )
  42.         12 0 do  i $3B4 pc!  dup c@  $3B5 pc!  1+  loop
  43.         drop  ;
  44.  
  45.  
  46. : GDARK ( -- ) \ graphics dark
  47.         VID.SEG 0 VID.SIZE 0 LFILL  ;
  48.  
  49.  
  50. : GLIGHT ( -- ) \ graphics light, opposite of dark.
  51.         VID.SEG 0 VID.SIZE $00FF LFILL  ;
  52.  
  53.  
  54. : HPAGED ( p -- ) \ select displaying lower or upper page of video buffer
  55.         0= if  $0A  else  $8A  then
  56.         $3B8 pc!  ;
  57.  
  58.  
  59. : HPAGEW ( p -- ) \ select writing to lower or upper page of video buffer
  60.         0= if  $B000  else  $B800  then
  61.         DUP =: VID.SEG  HERC-SEG !   ;
  62.  
  63.  
  64. : HERCULES      ( -- )
  65.         3 $3BF P!           \ set herc for FULL mode
  66.         $02 $3B8 PC!        \ set mode register for graphics, with video disabled
  67.         gtbl set-hmode
  68.         $8000 =: VID.SIZE   \ Hercules video buffer size
  69.         0 HPAGED            \ display the first graphics page
  70.         0 HPAGEW            \ enable writing to the first graphics page
  71.         720 =: HDOTS
  72.         348 =: VDOTS
  73.           2 =: #COLORS
  74.         GDARK  1 color ! ;  \ clear the screen
  75.  
  76.  
  77. : HTEXT         ( -- )
  78.         $20 $3B8 PC!    \ set mode register for text, with video disabled
  79.         ttbl set-hmode
  80.         $28 $3B8 PC!    \ re-enable video
  81.         DARK  ;
  82.  
  83.  
  84. LABEL XY_ADDR   ( x y -- a1:DX )
  85.         \ y in DX
  86.         \ x in CX
  87.         \ returns bit mask in AL and address in DI
  88.                 MOV AX, DX
  89.                 SHR AX, # 1
  90.                 SHR AX, # 1             \ row/4 in AX
  91.                 PUSH DX                 \ y  for later
  92.                 MOV BX, # 90
  93.                 MUL BX
  94.                 MOV DI, AX              \ DI is now row/4 * 90
  95.                 MOV AX, CX
  96.                 SHR AX, # 1
  97.                 SHR AX, # 1
  98.                 SHR AX, # 1             \ col/8 in AX
  99.                 ADD DI, AX              \ DI is now the byte address
  100.                 POP DX
  101.                 TEST DX, # 1
  102.              U> IF      ADD DI, # $2000 \ deal with row mod 4
  103.                 THEN
  104.                 TEST DX, # 2
  105.              U> IF      ADD DI, # $4000
  106.                 THEN
  107.                 AND CX, # 7
  108.                 MOV BX, # BIT-MASKS
  109.                 MOV AX, CX
  110.                 XLAT                    \ get bit mask
  111.                 RET             END-CODE
  112.  
  113.  
  114. CODE HPLOT      ( x y -- ) \ turn on pixel at x,y
  115.                 POP DX                  \ y
  116.                 POP CX                  \ x
  117.                 CALL XY_ADDR
  118.                 MOV CX, COLOR           \ is COLOR zero
  119.                 PUSH DS
  120.                 MOV DS, HERC-SEG
  121.           CX<>0 IF      NOT AL
  122.                         CMP CX, # 128
  123.                       < IF      OR  0 [DI], AL          \ set   the bit
  124.                         ELSE    XOR 0 [DI], AL          \ xor   the bit
  125.                         THEN
  126.                 ELSE    AND 0 [DI], AL                  \ clear the bit
  127.                 THEN
  128.                 POP DS
  129.                 NEXT            END-CODE
  130.  
  131.  
  132. CODE HPOINT     ( x y -- n1 )   \ Get status of pixel at x,y
  133.                 POP DX                  \ y
  134.                 POP CX                  \ x
  135.                 CALL XY_ADDR
  136.                 PUSH DS
  137.                 MOV DS, HERC-SEG
  138.                 MOV BL, 0 [DI]
  139.                 NOT AL
  140.                 AND AL, BL              \ mask the bit
  141.                 POP DS
  142.              0= IF      SUB AX, AX
  143.                 ELSE    MOV AX, # 1
  144.                 THEN
  145.                 1PUSH           END-CODE
  146.  
  147. \ Text for Hurcules Graphics Mode
  148.  
  149.  
  150. $0F000 value charseg
  151. $0FA6E value chartbl
  152. 0      value charadr
  153. 0      value hercX
  154. 0      value hercY
  155.  
  156.  
  157. : h-at ( x y -- ) \ AT for Hercules
  158.         =: hercY  =: hercX  ;
  159.  
  160.  
  161. : herc-at ( x y -- ) \ AT for Hercules
  162.         8 * =: hercY  8 * =: hercX  ;
  163.  
  164.  
  165. : herc-at? ( -- x y ) \ AT? for Hercules
  166.         hercX 8 *  hercY 8 * ;
  167.  
  168.  
  169. : herc-emit ( c -- )
  170.         8 * chartbl +  =: charadr
  171.         hercX 8 /
  172.         hercY 4 /mod 90 *  swap $2000 * +
  173.         +  ( video-byte-addr )
  174.  
  175. \ POINTOFFSET       = INT[ROW/4] * 90 + REM[ROW/4]*$2000 + INT[COL/8]
  176. \ PIXEL(1 BIT)ADDR  = REM[COL/8] {WITHIN BYTE}
  177. \ Next bit, step along byte and to next byte.
  178. \ Next row, add $2000, and add 90 when wrapping.
  179.  
  180.         8 0 do  charseg charadr c@l  incr> charadr
  181.                 over herc-seg @ swap c!l
  182.                 $2000 +  dup $7FFF u> if 90 + then  $7FFF and
  183.           loop
  184.         drop
  185.         hercX 8 + 720 /mod  if 8 +!> hercY then  =: hercX  ;
  186.  
  187.  
  188. : herc-typeL ( s a l -- )
  189.         bounds ?do  dup i c@L emit  loop  drop ;
  190.  
  191.  
  192. : herc-type ( a l -- )
  193.         bounds ?do  i c@ emit  loop  ;
  194.  
  195.  
  196. : herc-cr ( -- )
  197.         hercY 8 +  319 min  =: hercY   off> hercX  ;
  198.  
  199.  
  200. : HERCULES$     ( -- )
  201.         HERCULES            \ switch to Hercules graphics mode
  202.         ['] herc-typeL is typeL
  203.         ['] herc-type  is type
  204.         ['] herc-emit  is emit
  205.         ['] herc-at    is at
  206.         ['] herc-at?   is at?
  207.         ['] herc-cr    is cr  ;
  208.  
  209.  
  210. : HTEXT$        ( -- )
  211.         HTEXT           \ switch to text mode
  212.         ['] QtypeL is typeL
  213.         ['] (type) is type
  214.         ['] (emit) is emit
  215.         ['] ibm-at is at
  216.         ['] ibm-at? is at?
  217.         ['] crlf is cr
  218.         DARK  ;
  219.  
  220.  
  221. }
  222.  
  223.