home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / compiler / fpc / source / therc.seq < prev    next >
Text File  |  1990-03-28  |  5KB  |  148 lines
  1. \\ THERC.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 TARGET >LIBRARY           \ A Library file
  14.  
  15.  
  16. 0 VALUE VDOTS       \ verticle dots in screen
  17. 0 VALUE HDOTS       \ horizontal dits 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. TABLE GTBL
  27.         $35 c, $2D c, $2E c, $07 c, $5B c, $02 c,
  28.         $57 c, $57 c, $02 c, $03 c, $00 c, $00 c,
  29. END-TABLE
  30.  
  31.  
  32. TABLE 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. END-TABLE
  36.  
  37.  
  38. TABLE BIT-MASKS
  39.         $7F c, $BF c, $DF c, $EF c, $F7 c, $FB c, $FD c, $FE c,
  40. END-TABLE
  41.  
  42.  
  43. : SET-HMODE     ( tbl -- )
  44.         12 0 do  i $3B4 pc!  dup c@  $3B5 pc!  1+  loop
  45.         drop  ;
  46.  
  47. : GDARK ( -- ) \ graphics dark
  48.     VID.SEG 0 VID.SIZE 0 LFILL  ;
  49.  
  50.  
  51. : GLIGHT ( -- ) \ graphics light, opposite of dark.
  52.     VID.SEG 0 VID.SIZE $0FF LFILL  ;
  53.  
  54.  
  55. : HPAGED ( p -- ) \ select displaying lower or upper page of video buffer
  56.         0= if  $0A  else  $8A  then
  57.         $3B8 pc!  ;
  58.  
  59.  
  60. : HPAGEW ( p -- ) \ select writing to lower or upper page of video buffer
  61.         0= if  $B000  else  $B800  then
  62.         DUP =: VID.SEG  HERC-SEG !   ;
  63.  
  64.  
  65. : HERCULES      ( -- )
  66.         3 $3BF P!           \ set herc for FULL mode
  67.         $02 $3B8 PC!        \ set mode register for graphics, with video disabled
  68.         gtbl set-hmode
  69.         $8000 =: VID.SIZE   \ Hercules video buffer size
  70.         0 HPAGED            \ display the first graphics page
  71.         0 HPAGEW            \ enable writing to the first graphics page
  72.         720 =: HDOTS
  73.         348 =: VDOTS
  74.           2 =: #COLORS
  75.         GDARK  1 color !  ; \ clear the screen
  76.  
  77.  
  78. : HTEXT         ( -- )
  79.         $20 $3B8 PC!    \ set mode register for text, with video disabled
  80.         ttbl set-hmode
  81.         $28 $3B8 PC!    \ re-enable video
  82.         DARK ;
  83.  
  84.  
  85. LABEL XY_ADDR   ( x y -- a1:DX )
  86.                 MOV DX, BX              \ y
  87.                 LODSW
  88.                 MOV CX, AX              \ x
  89.                 MOV AX, DX
  90.                 SHR AX, # 1
  91.                 SHR AX, # 1             \ row/4 in AX
  92.                 PUSH DX                 \ y
  93.                 MOV BX, # 90
  94.                 MUL BX
  95.                 MOV DI, AX              \ DI is now row/4 * 90
  96.                 MOV AX, CX
  97.                 SHR AX, # 1
  98.                 SHR AX, # 1
  99.                 SHR AX, # 1             \ col/8 in AX
  100.                 ADD DI, AX              \ DI is now the byte address
  101.                 POP DX
  102.                 TEST DX, # 1
  103.              U> IF      ADD DI, # $2000 \ deal with row mod 4
  104.                 THEN
  105.                 TEST DX, # 2
  106.              U> IF      ADD DI, # $4000
  107.                 THEN
  108.                 AND CX, # 7
  109.                 MOV BX, # BIT-MASKS
  110.                 MOV AX, CX
  111.                 XLAT                    \ get bit mask
  112.                 RET             END-CODE
  113.  
  114.  
  115. CODE HPLOT      ( x y -- ) \ turn on pixel at x,y
  116.                 CALL XY_ADDR
  117.                 MOV CX, COLOR           \ is COLOR zero
  118.                 PUSH DS
  119.                 MOV DS, HERC-SEG
  120.           CX<>0 IF      NOT AL
  121.                         CMP CX, # 128
  122.                       < IF      OR  0 [DI], AL          \ set   the bit
  123.                         ELSE    XOR 0 [DI], AL          \ xor   the bit
  124.                         THEN
  125.                 ELSE    AND 0 [DI], AL                  \ clear the bit
  126.                 THEN
  127.                 POP DS
  128.                 LOAD_BX                 \ reload BX
  129.                 RET             END-CODE
  130.  
  131.  
  132. CODE HPOINT     ( x y -- n1 )   \ Get status of pixel at x,y
  133.                 CALL XY_ADDR
  134.                 PUSH DS
  135.                 MOV DS, HERC-SEG
  136.                 MOV BL, 0 [DI]
  137.                 NOT AL
  138.                 AND BL, AL              \ mask the bit
  139.                 POP DS
  140.              0= IF      SUB BX, BX
  141.                 ELSE    MOV BX, # 1
  142.                 THEN
  143.                 RET             END-CODE
  144.  
  145.  
  146. FORTH TARGET >TARGET
  147. }
  148.