QUAN COLOR

QUAN viX
QUAN viY
QUAN viX1
QUAN viY1
QUAN viZ1
QUAN viX2
QUAN viY2
QUAN viZ2
QUAN viDX
QUAN viDY
QUAN viDZ
QUAN viD
QUAN viD1
QUAN viD2

VECT viX++
VECT viY++

: viX1+ viX 1+ TO viX ;
: viY1+ viY 1+ TO viY ;
: viY1- viY 1 - TO viY ;

: vi?DX++
  viD 0 >
  IF
    viD viD2 + TO viD
    viX 1+ TO viX
  ELSE
    viD viD1 + TO viD
  THEN
;
: vi?DY++
  viD 0 >
  IF
    viD viD2 + TO viD
    viY  viY2 viY1 > IF 1+ ELSE 1 - THEN TO viY
  ELSE
    viD viD1 + TO viD
  THEN
;

: viPREPARE_LINE
  viX2 viX1 < IF viX1 viX2 TO viX1 TO viX2 viY1 viY2 TO viY1 TO viY2 THEN
  viX2 viX1 - TO viDX
  viY2 viY1 - ABS TO viDY
  viDX viDY >
  IF
    viDY 1 LSHIFT viDX - TO viD
    viDY 1 LSHIFT TO viD1
    viDY viDX - 1 LSHIFT TO viD2
    ['] viX1+ TO viX++
    ['] vi?DY++ TO viY++
  ELSE
    viDX 1 LSHIFT viDY - TO viD
    viDX 1 LSHIFT TO viD1
    viDX viDY - 1 LSHIFT TO viD2
    ['] vi?DX++  TO viX++
    viY2 viY1 > IF ['] viY1+ TO viY++ ELSE ['] viY1- TO viY++ THEN
  THEN
;

: LINE1 // X1, Y1, X2, Y2 -->
  TO viY2 TO viX2 TO viY1 TO viX1
  viX1 viX2 = viY1 viY2 = AND IF
  viX1 viY1 COLOR PIXEL ELSE
    viPREPARE_LINE
    viX1 TO viX viY1 TO viY
    BEGIN
      viX viY COLOR PIXEL
      viX++ viY++
      viX viX2 = viY viY2 = AND
    UNTIL
    viX viY COLOR PIXEL
  THEN
;

: BOX // X1, Y1, X2, Y2 -->

  3 PICK 2 PICK 2DUP > IF SWAP THEN
  4 PICK 3 PICK 2DUP > IF SWAP THEN
  ROT SWAP

  3 PICK 3 PICK 3 PICK 6 PICK -    COLOR HLINE
  3 PICK 3 PICK 2 PICK 5 PICK -    COLOR VLINE
  1 PICK 3 PICK 2 PICK 5 PICK - 1+ COLOR VLINE
  3 PICK 1 PICK 3 PICK 6 PICK -    COLOR HLINE
  8 0 DO DROP LOOP
;

: PAINTBOX // X1, Y1, X2, Y2 -->
  1+ ROT DO
    OVER I 2 PICK 4 PICK - 1+ COLOR HLINE
  LOOP
  DROP DROP
;

QUAN trX1
QUAN trY1
QUAN trX2
QUAN trY2
QUAN trX3
QUAN trY3
QUAN trY
FLOAT trXL
FLOAT trXR

FLOAT trK1
FLOAT trK2

: TRIANGLE1
\  trX1 trY1 COLOR PIXEL
  trX1 S>F trXL F!
  trX1 S>F trXR F!
  trY1 TO trY
  trY3 trY1 = IF trX3 trX1 - S>F trK1 F! ELSE
                 trX3 trX1 - S>F trY3 trY1 - 1+ S>F F/ trK1 F!
              THEN
  trY2 trY1 = IF trX2 trX1 - S>F trK2 F! ELSE
                 trX2 trX1 - S>F trY2 trY1 - 1+ S>F F/ trK2 F!
              THEN
  BEGIN
    trY trY2 1+ <
  WHILE
    trXL F@ 0.5 F+ F>S trXR F@ 0.5 F+ F>S
    2DUP > IF SWAP THEN
    OVER - 1+
    trY SWAP COLOR HLINE
    trY 1+ TO trY
    trXL F@ trK1 F@ F+ trXL F!
    trXR F@ trK2 F@ F+ trXR F!
  REPEAT

  trY3 trY2 = IF trX3 trX2 - S>F trK2 F! ELSE
                 trX3 trX2 - S>F trY3 trY2 - 1+ S>F F/ trK2 F!
              THEN
  trY3 trY1 = IF trX3 trX1 - S>F trK1 F! ELSE
                 trX3 trX1 - S>F trY3 trY1 - 1+ S>F F/ trK1 F!
              THEN
  BEGIN
    trY trY3 1+ <
  WHILE
    trXL F@ 0.5 F+ F>S trXR F@ 0.5 F+ F>S
    2DUP > IF SWAP THEN
    OVER - 1+
    trY SWAP COLOR HLINE
    trY 1+ TO trY
    trXL F@ trK1 F@ F+ trXL F!
    trXR F@ trK2 F@ F+ trXR F!
  REPEAT
;

: SORT-TRIANGLE-VERTEX
  trY3 trY2 < IF trX2 trX3 TO trX2 TO trX3 trY2 trY3 TO trY2 TO trY3 THEN
  trY2 trY1 < IF trX1 trX2 TO trX1 TO trX2 trY1 trY2 TO trY1 TO trY2 THEN
  trY3 trY2 < IF trX2 trX3 TO trX2 TO trX3 trY2 trY3 TO trY2 TO trY3 THEN
;

: TRIANGLE // X1, Y1, X2, Y2, X3, Y3 -->
  TO trY3 TO trX3
  TO trY2 TO trX2
  TO trY1 TO trX1
  SORT-TRIANGLE-VERTEX
  TRIANGLE1
;
                     

CLS
0x00FF00 TO COLOR
100 100 200 345 LINE1

100 100 200 320 150 40 TRIANGLE

QUAN X1
QUAN Y1

: LEFT
  MOUSE-X @ TO X1
  MOUSE-Y @ TO Y1
;
: LEFTUP
  X1 Y1 MOUSE-X @ MOUSE-Y @ BOX
;

' LEFT TO <MOUSE_LEFT>
' LEFTUP TO <MOUSE_LEFT_UP>

: DUPS // Arr[1..M] M --> Arr[1..M] Arr[1..M]
DUP 0 DO
  DUP PICK SWAP
LOOP
DROP
;

: DROPS // Arr[1..M] M -->
0 DO DROP LOOP
;

: rectWITHIN // x y x1 y1 x2 y2 --> bool
SWAP 4 XCHG
ROT ROT WITHIN
3 XCHG 2 XCHG WITHIN AND
;

// Графика
: RGB-> // Color --> R G B
65536 /MOD
256 /MOD
ROT ROT SWAP
;

: LINE // X1, Y1, X2, Y2 -->
  TO viY2 TO viX2 TO viY1 TO viX1
  viX1 viX2 = viY1 viY2 = AND IF
  viX1 viY1 COLOR PIXEL ELSE
    viPREPARE_LINE
    viX1 TO viX viY1 TO viY
    BEGIN
      viX viY COLOR PIXEL
      viX++ viY++
      viX viX2 = viY viY2 = AND
    UNTIL
    viX viY COLOR PIXEL
  THEN
;

: Box // x y ширина высота цвет -->
4 PICK 4 PICK
2 DUPS
6 PICK 5 PICK HLINE
3 PICK 3 PICK VLINE
4 PICK 3 PICK + 4 PICK 3 PICK 1+ 3 PICK VLINE
4 PICK 4 PICK 3 PICK + 4 PICK 1+ 3 PICK HLINE
5 DROPS
;

: FillBox // x y ширина высота цвет -->
3 PICK 2 PICK + 4 PICK DO
  4 PICK I 4 PICK 3 PICK HLINE
LOOP
5 DROPS
;

: 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
;

: GradientBox // x y ширина высота цвет1 цвет2 -->
  4 PICK 3 PICK + 5 PICK DO
  5 PICK I // x i
  5 PICK   // ширина
  OVER 8 PICK - 100 * 6 PICK / // Percent=(i-y)/высота
  5 PICK 5 PICK Gradient // Percent цвет1 цвет2 --> color
  HLINE
LOOP
6 DROPS
;

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

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

-1 VALUE TextOpaque
-1 VALUE BackOpaque

// Печать текста с прозрачным фоном
// Работает аналогоично слову PRINT
: .PRINT // p --->
DUP C@ IF
  BEGIN
  DUP C@ 16 * SYMBOLS +
   16 0 DO
    DUP I + C@
    0x80
    8 0 DO
     OVER OVER AND IF
      TextOpaque NOT IF WHERETEXTXY GETCOLOR PIXEL THEN
     ELSE
      BackOpaque NOT IF WHERETEXTXY GETBGCOLOR PIXEL THEN
     THEN
     2/
     1 +X
    LOOP
    DROP DROP
    -8 +X
    1 +Y
   LOOP
   DROP
   8 +X
   -16 +Y
  1+ DUP C@ 0 = UNTIL
THEN
DROP
;

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

: gPRINT // p -->
DUP strLen
WHERETEXTXY ROT // x y len
8 * 16
GETCOLOR GETBGCOLOR
GradientBox

BackOpaque TextOpaque GETBGCOLOR
  0 TO BackOpaque
-1 TO TextOpaque
3 PICK .PRINT
SETBGCOLOR TO TextOpaque TO BackOpaque
DROP
;

CLS
0x00FF00 TO COLOR
100 100 200 345 LINE1

100 100 200 320 150 40 TRIANGLE

QUAN X1
QUAN Y1

: LEFT
  MOUSE-X @ TO X1
  MOUSE-Y @ TO Y1
;

: LEFTUP
  MOUSE-X @ X1 MIN
  MOUSE-Y @ Y1 MIN
  MOUSE-X @ X1 - ABS
  MOUSE-Y @ Y1 - ABS
  COLOR FillBox
;

' LEFT TO <MOUSE_LEFT>
' LEFTUP TO <MOUSE_LEFT_UP>

3 PICK 2 PICK 2DUP > IF SWAP THEN
4 PICK 3 PICK 2DUP > IF SWAP THEN
ROT SWAP

X, Y, Ширина, Высота