Transforms mostly working.

ueforth/common/grf_test.fs

@@ -31,8 +31,23 @@ grf
     then
 )
     0 to color 0 0 width height box
-    LEFT-BUTTON pressed? if $ccccff else $ffccff then to color
+    g{
-    mouse-x mouse-y height heart
+      640 480 viewport
+      $ff0000 to color
+      0 0 640 480 box
+      $ff7700 to color
+      0 0 400 300 box
+
+      g{
+        mouse-x mouse-y screen>g translate
+        LEFT-BUTTON pressed? if $ccccff else $ffccff then to color
+        g{ -100 -100 translate 0 0 100 heart }g
+        g{ 100 -100 translate 0 0 100 heart }g
+        g{ -100 100 translate 0 0 100 heart }g
+        g{ 100 100 translate 0 0 100 heart }g
+        g{ -50 -50 100 100 box }g
+      }g
+    }g
     flip
   event FINISHED = until
   bye

ueforth/common/grf_utils.fs

@@ -17,6 +17,14 @@
 \   ( $rrggbb ) to color
 \ Drawing:
 \   box ( x y w h -- )
+\ Transforms:
+\   g{ ( -- ) Preserve transform
+\   }g ( -- ) Restore transform
+\   translate ( x y -- )
+\   scale ( nx dx ny dy -- )
+\   viewport ( w h -- )
+\ Conversions:
+\   screen>g ( x y -- x' y' ) Transform screen to viewport
 
 also internals
 grf definitions
@@ -34,14 +42,12 @@ $10000 value sx   $10000 value sy
   \ x y pixel w 1- for color over l! 4 + next drop ;
   x y pixel w color fill32 ;
 
-grf definitions also internals
+create gstack 1024 cells allot
-
+gstack value gp
-: box { left top w h }
+: >g ( n -- ) gp ! gp cell+ to gp ;
-  left sx * tx + 16 rshift to left
+: g> ( -- n ) gp cell - to gp gp @ ;
-  top sy * ty + 16 rshift to top
-  w sx * 16 rshift to w
-  h sy * 16 rshift to h
 
+: raw-box { left top w h }
   left w + top h + { right bottom }
   left 0 max to left
   top 0 max to top
@@ -53,4 +59,33 @@ grf definitions also internals
   top h 1- for left over w hline 1+ next drop
 ;
 
+grf definitions also internals
+
+: box { left top w h }
+  left sx * tx + 16 rshift
+  top sy * ty + 16 rshift
+  w sx * 16 rshift
+  h sy * 16 rshift
+  raw-box
+;
+
+: screen>g ( x y -- x' y' ) 16 lshift ty - sy / swap
+                            16 lshift tx - sx / swap ;
+
+: g{   sx >g   sy >g   tx >g   ty >g ;
+: }g   g> to ty  g> to tx   g> to sy   g> to sx ;
+: translate ( x y -- ) sy * +to ty   sx * +to tx ;
+: scale ( nx dx ny dy -- )
+  sy -rot */ to sy
+  sx -rot */ to sx ;
+: viewport { w h }
+  width 2/ height 2/ translate
+  10000 width height */ 10000 w h */ < if
+    width w  width h w */ h scale
+  else
+    height w h */ w  height h scale
+  then
+  w 2/ negate h 2/ negate translate
+;
+
 only forth definitions

ueforth/common/heart.fs

@@ -58,23 +58,31 @@ heart-end heart-size 0 fill
 
 512 29 32 */ constant heart-ratio
 
-grf definitions also internals
+: raw-heart 0 { x y sx sy r }
-
-: heart 0 { x y s r }
   heart-start c@ 0= if heart-initialize then
-  y s 2/ - to y
+  y sy 2/ - to y
-  s 0 do
+  sy 0 do
-    i heart-size s */ to r
+    i heart-size sy */ to r
-    x heart-start r + c@ s heart-ratio */ +
+    x heart-start r + c@ sx heart-ratio */ +
       y i +
-      heart-end r + c@ s heart-ratio */
+      heart-end r + c@ sx heart-ratio */
-      1 box
+      1 raw-box
     x heart-start r + c@
-      heart-end r + c@ + s heart-ratio */ -
+      heart-end r + c@ + sx heart-ratio */ -
       y i +
-      heart-end r + c@ s heart-ratio */
+      heart-end r + c@ sx heart-ratio */
-      1 box
+      1 raw-box
   loop
 ;
 
+grf definitions also internals
+
+: heart 0 { x y s r }
+  x sx * tx + 16 rshift
+  y sy * ty + 16 rshift
+  s sx * 16 rshift
+  s sy * 16 rshift
+  raw-heart
+;
+
 only forth definitions