home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / compiler / fpc / source / monocrom.seq < prev    next >
Text File  |  1989-09-07  |  3KB  |  74 lines
  1. \ MONOCROM.SEQ  Monochrome support words                by Tom Zimmer
  2.  
  3. DECIMAL
  4.  
  5. \ Video attribute control mechanism for monochrome by Tom Zimmer
  6.  
  7. $07 VALUE NORMVAL                               \ VALUE FOR NORMAL VIDEO
  8. $78 VALUE REVVAL                                \ VALUE FOR REVERSE VIDEO
  9. $07 VALUE NORMALVAL
  10. $78 VALUE REVERSEVAL
  11.  
  12. : >NONE         ( --- ) NORMVAL ATTRIB C! ;     \ NORMAL
  13. : >NONEBG       ( --- ) NORMVAL $F0 AND ATTRIB C@ $0F AND OR ATTRIB C! ;
  14. : >REVERSE      ( --- ) REVVAL  ATTRIB C! ;     \ REVERSE
  15. : >UL           ( --- ) $01 ATTRIB C! ;         \ UNDERLINE
  16. : >BOLD         ( --- ) $7F ATTRIB C! ;         \ BRIGHT
  17. : >BOLDUL       ( --- ) $79 ATTRIB C! ;         \ BOLD UNDERLINE
  18. : >BOLDBLNK     ( --- ) $8F ATTRIB C! ;         \ BOLD BLINK
  19. : >REVBLNK      ( --- ) $F0 ATTRIB C! ;         \ REVERSE BLINK
  20.  
  21. \       Some extra words, not loaded for now.
  22.  
  23. \ : >BOLDBLNKUL   ( --- ) $89 ATTRIB C! ;       \ BOLD BLINK & UNDERLINE
  24. \ : >BLINK        ( --- ) $87 ATTRIB C! ;       \ BLINK
  25. \ : >BLANK        ( --- ) $00 ATTRIB C! ;       \ BLANK, NO DISPLAY
  26.  
  27. ' >NONE    IS >NORM
  28. ' >REVERSE IS >REV
  29. ' >NONEBG  IS >NORMBG
  30.  
  31. >NORM           \ Default to Normal video.
  32.  
  33. : >MONO         ( --- )         \ Select hilighting for monochrome monitor.
  34.                 ['] >UL         IS >ATTRIB1 ['] >BOLDBLNK IS >ATTRIB5
  35.                 ['] >BOLDUL DUP IS >ATTRIB2               IS >ATTRIB6
  36.                 ['] >BOLD   DUP IS >ATTRIB3               IS >ATTRIB7
  37.                 ['] >REV    DUP IS >ATTRIB4               IS >ATTRIB8
  38.                 >NORM ;
  39.         >MONO
  40.  
  41. ' >MONO IS INITMONO     \ Enable attributes according to video board.
  42.  
  43. ' >MONO IS INITCOLOR    \ Enable attributes SAME AS MONO FOR NOW.
  44.  
  45. \ Reverse video support.
  46.  
  47. : invert-screen         ( --- )
  48.                         blank.color
  49.                         video-seg @ rows cols 2* * 1
  50.                         do      dup i c@l dup NORMVAL =
  51.                                 if      drop REVVAL over i c!l
  52.                                 else    REVVAL =
  53.                                         if      NORMVAL over i c!l
  54.                                         then
  55.                                 then
  56.                      2 +loop    drop show.color ;
  57.  
  58. : white-on-black        ( --- )
  59.                         NORMVAL NORMALVAL <>
  60.                         if      invert-screen
  61.                         then
  62.                         NORMALVAL  =: NORMVAL
  63.                         REVERSEVAL =: REVVAL
  64.                         >norm ;
  65.  
  66. : black-on-white        ( --- )
  67.                         NORMVAL REVERSEVAL <>
  68.                         if      invert-screen
  69.                         then
  70.                         REVERSEVAL =: NORMVAL
  71.                         NORMALVAL  =: REVVAL
  72.                         >norm ;
  73.  
  74.