diff --git a/ueforth/common/grf_test.fs b/ueforth/common/grf_test.fs index e517c2f..696ee1f 100755 --- a/ueforth/common/grf_test.fs +++ b/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 - mouse-x mouse-y height heart + g{ + 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 diff --git a/ueforth/common/grf_utils.fs b/ueforth/common/grf_utils.fs index 0ab8a55..a0c7748 100644 --- a/ueforth/common/grf_utils.fs +++ b/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 - -: box { left top w h } - left sx * tx + 16 rshift to left - top sy * ty + 16 rshift to top - w sx * 16 rshift to w - h sy * 16 rshift to h +create gstack 1024 cells allot +gstack value gp +: >g ( n -- ) gp ! gp cell+ to gp ; +: g> ( -- n ) gp cell - to gp gp @ ; +: 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 diff --git a/ueforth/common/heart.fs b/ueforth/common/heart.fs index 2f34f81..f82b07a 100644 --- a/ueforth/common/heart.fs +++ b/ueforth/common/heart.fs @@ -58,23 +58,31 @@ heart-end heart-size 0 fill 512 29 32 */ constant heart-ratio -grf definitions also internals - -: heart 0 { x y s r } +: raw-heart 0 { x y sx sy r } heart-start c@ 0= if heart-initialize then - y s 2/ - to y - s 0 do - i heart-size s */ to r - x heart-start r + c@ s heart-ratio */ + + y sy 2/ - to y + sy 0 do + i heart-size sy */ to r + x heart-start r + c@ sx heart-ratio */ + y i + - heart-end r + c@ s heart-ratio */ - 1 box + heart-end r + c@ sx heart-ratio */ + 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 */ - 1 box + heart-end r + c@ sx heart-ratio */ + 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