white_TigR

' EMIT VALUE 'EMIT
' PRINT VALUE 'PRINT

: Flower
 FDUP 0.5 F- F>S S>F F-
 FDUP 1.0 F= IF
  1.0 F-
 THEN
;

: FMOD // FS: x y --> x(mod)y
 10000.0 F* F>S
 10000.0 F* F>S
 SWAP MOD S>F
 10000.0 F/
;

// : Flower
// 1.0 FMOD
// ;

: RGB-> // Color --> R G B
 65536 /MOD
 256 /MOD
 ROT ROT SWAP
;

: Gradient // Percent Color1 Color2 --> Color
           // Переход от цвета1 к цвету2
           // Percent - 0..100
 SWAP RGB->
 3 PICK RGB-> // DS: Percent Color2 R1 G1 B1 R2 G2 B2
 3 PICK - 7 PICK * 100 / 3 PICK + 3 XCHG DROP // DS: Percent Color2 R1 G1 Bnew R2 G2
 3 PICK - 6 PICK * 100 / 3 PICK + 3 XCHG DROP // DS: Percent Color2 R1 Gnew Bnew R2
 3 PICK - 5 PICK * 100 / 3 PICK + 3 XCHG DROP // DS: Percent Color2 Rnew Gnew Bnew
 RGB
 2 XCHG DROP DROP
;

32 VALUE fontH
16 VALUE fontW

: TOfontWH // w h -->
 TO fontH
 TO fontW
;

: +X // n -->
 WHERETEXTXY ROT ROT + SWAP TEXTXY
;

: +Y // n -->
 WHERETEXTXY ROT + TEXTXY
;

: GetBit // addr bit(0..7) --> 0|1
 1 SWAP 1+ 0 DO 2* LOOP 2/
 SWAP C@ AND IF 1 ELSE 0 THEN
;

: GetSymbolBit // n x(0..7) y(0..15) --> 0|1
 2 PICK 16 * + SYMBOLS + SWAP
 8 SWAP - GetBit
 SWAP DROP
;

: BitColor // 0|1 --> color
 IF GETCOLOR ELSE GETBGCOLOR THEN
;

: X>F // DS: x --> FS: x
 S>F fontW S>F F/ 8.0  F*
;

: Y>F // DS: x --> FS: x
 S>F fontH S>F F/ 16.0 F*
;

: XY>fXY // x y --> fX fY
 SWAP X>F F>S
 SWAP Y>F F>S
;

: NORMAL // n x y --> color
 XY>fXY GetSymbolBit BitColor
;

: SMOOTH // n x y --> color
 OVER OVER XY>fXY // n x y fX fY
 4 PICK 4 PICK 4 PICK NORMAL // n x y fX fY color

 // Размытие по оси X

 4 PICK X>F Flower 100.0 F* F>S

 DUP 2 PICK
 8 PICK 6 PICK 1- 0 7 RANGE 6 PICK GetSymbolBit BitColor
 Gradient

 SWAP 100 SWAP - 2 PICK
 8 PICK 6 PICK 1+ 0 7 RANGE 6 PICK GetSymbolBit BitColor
 Gradient

 50 ROT ROT Gradient

 // Размытие по оси Y

 4 PICK X>F Flower 100.0 F* F>S

 DUP 3 PICK
 9 PICK 7 PICK 7 PICK 1- 0 15 RANGE GetSymbolBit BitColor
 Gradient

 SWAP 100 SWAP - 3 PICK
 9 PICK 7 PICK 7 PICK 1+ 0 15 RANGE GetSymbolBit BitColor
 Gradient

 50 ROT ROT Gradient

 50 ROT ROT Gradient

 6 XCHG
 6 0 DO DROP LOOP
;

: sEMIT // n -->
 fontH 16 = fontW 8 = AND IF
  EMIT
 ELSE
  fontH 0 DO
   fontW 0 DO
    DUP I J
    NORMAL
    WHERETEXTXY ROT PIXEL
    1 +X
   LOOP
   0 fontW - +X
   1 +Y
  LOOP
  fontW +X
  0 fontH - +Y
  DROP
 THEN
;

: strLen // p --> len
 0
 OVER C@ IF
  BEGIN 1+ OVER OVER + C@ 0 = UNTIL
 THEN
 SWAP DROP
;

: PRINT // p -->
 DUP strLen
 0 DO
  DUP I + C@ sEMIT
 LOOP
 DROP
;

: zeros
 51 2 DO
  I 16 = IF RED ELSE GREEN THEN SETCOLOR
  I 2/ I TOfontWH
  48 sEMIT
 LOOP
;

: test
 CLS

 0 0 GOTOXY zeros

 0 50 TEXTXY
 150 400 TOfontWH " Forth" PRINT
;