\ color 3/14/00 11:21 pm NAB

needs toolkit

0 enum mode
  mode DisplayModeGetDefaults
  mode DisplayModeGet
  mode DisplayModeSetToDefaults
  mode DisplayModeSet
  mode DisplayModeGetSupportedDepths
  mode DisplayModeSupportsColor

: color-depth ( bits -- )
  0 sp@
  0. 2swap
  0.
  0.
  DisplayModeSet >byte
  ScrDisplayMode throw 2drop ;

: grayscale ( -- )  2 color-depth ;

: monochrome ( -- )  1 color-depth ;

: >rgb ( r g b -- rgb. )
  swap >byte or swap ;

: rgb> ( rgb. -- r g b )
  swap dup 8 rshift swap 15 and ;

: gray ( gray -- rgb. )
  dup dup ;

: color>gray ( r g b -- gray )
  100 877 */  swap  100 170 */  +
  swap  100 334 */  + ;

: set-colors ( fore-rgb. back-rgb. -- )
  sp@ 0. 2swap 0. 2over 16 m+
  WinSetColors 2drop 2drop ;

: get-colors ( -- fore-rgb. back-rgb. )
  0. 0. sp@ 0. 2over 4 m+ 0.
  WinSetColors ;

: foreground ( rgb. -- )
  sp@ 2>r
  0. 0. 0. 2r> WinSetColors 2drop ;

: background ( rgb. -- )
  sp@ 2>r
  0. 2r> 0. 0. WinSetColors 2drop ;

: color: ( r g b "name" -- )
  >rgb 2constant ;

0 gray color: black
127 gray color: dark-gray
191 gray color: light-gray
255 gray color: white

 \ Example:
 \ grayscale
 \ light-gray background
 \ black foreground