commit aed095e7171dab68aaec1575c71de62d626cf70b
parent b166e6732a0aeb65462eea70fec124bcf6e3c167
Author: Virgil Dupras <hsoft@hardcoded.net>
Date: Mon, 26 Dec 2022 18:28:09 -0500
gr/rect: new unit
see doc/rect
Diffstat:
6 files changed, 118 insertions(+), 0 deletions(-)
diff --git a/Makefile b/Makefile
@@ -61,6 +61,10 @@ testcc: dusk
testemul: dusk
echo "' byefail to abort f<< tests/emul/all.fs bye" | ./dusk || (echo; exit 1)
+.PHONY: testgr
+testgr: dusk
+ echo "' byefail to abort f<< tests/gr/all.fs bye" | ./dusk || (echo; exit 1)
+
.PHONY: clean
clean:
rm -f $(TARGETS) dusk.o fs/init.fs posix/boot.fs memdump *.bin *.img
diff --git a/fs/doc/rect.fs b/fs/doc/rect.fs
@@ -0,0 +1,56 @@
+# Rectangles
+
+Provides a Rect structure that helps with operations on rectangles.
+
+## API
+
+Fields:
+
+x
+y
+width
+height
+
+:new ( x y width height -- rect )
+ Allocate a new rectangle with specified values.
+
+:tmpnew ( x y width height -- rect )
+ Allocate new rectangle in system scratchpad (doc/alloc).
+
+:topleft ( self -- x y )
+ Top-left point of the rectangle.
+
+:bottomright ( self -- x y )
+ Bottom-right point of the rectangle.
+
+:= ( other self -- f )
+ Whether the rectangle has the same field values as "other".
+
+:null? ( self -- f )
+ Whether the rectangle has a 0 width or height.
+
+:haspoint? ( x y self -- f )
+ Whether coordinates "x,y" are inside the rectangle.
+
+:hasrect? ( other self -- f )
+ Wether rectangle "other" is entirely contained (can be equal) in rectangle
+ "self".
+
+:intersects? ( other self -- f )
+ Whether one part of "other" intersects with "self" (can be contained).
+
+:intersection ( other self -- rect )
+ Yields a rectangle (created with :tmpnew) that represents the intersection of
+ "other" and "self". If there is no intersection, will yield a null rectangle.
+
+:copy ( other self -- )
+ Copy values in all fields of "other" into "self".
+
+:move ( x y self -- )
+ Move "self"'s top-left point to "x,y".
+
+:resize ( width height self -- )
+ Resize "self" to "width,height".
+
+:print ( self -- )
+ Print a human readable representation of "self".
diff --git a/fs/gr/rect.fs b/fs/gr/rect.fs
@@ -0,0 +1,34 @@
+\ Rectangles. see doc/rect
+require /sys/scratch.fs
+
+struct[ Rect
+ sfield x
+ sfield y
+ sfield width
+ sfield height
+
+ : :new ( x y width height -- rect ) >r rot , swap , , r> , here SZ - ;
+ : :tmpnew ( x y width height -- rect ) SZ syspad :[ :new drop syspad :] ;
+ : :topleft ( self -- x y ) dup x swap y ;
+ : :bottomright ( self -- x y ) dup x over width + over y rot height + ;
+ : := ( other self -- f ) SZ []= ;
+ : :null? ( self -- f ) dup width swap height and not ;
+ : :haspoint? ( x y self -- f ) >r \ V1=self
+ r@ y - r@ height <= swap r@ x - r> width <= and ;
+ : :hasrect? ( other self -- f ) >r \ V1=self
+ dup :topleft r@ :haspoint? if :bottomright r> :haspoint? else rdrop 0 then ;
+ : :intersects? ( other self -- f ) >r \ V1=self
+ dup :topleft r@ :haspoint? if rdrop 1 else r> :topleft rot :haspoint? then ;
+ : :intersection ( other self -- rect ) >r \ V1=self
+ dup x V1 x max >r \ V2=x
+ dup y V1 y max >r \ V3=y
+ :bottomright V1 :bottomright ( x1 y1 x2 y2 )
+ rot min V3 - dup 0< if drop 0 then >r ( x1 x2 ) \ V4=height
+ min V2 - dup 0< if drop 0 then ( width )
+ V2 swap V3 swap V4 :tmpnew rfree ;
+ : :copy ( other self -- ) SZ move ;
+ : :move ( x y self -- ) tuck to y to x ;
+ : :resize ( width height self -- ) tuck to height to width ;
+ : :print ( self -- )
+ ." Rect " @+ . ',' emit @+ . spc> @+ . ',' emit @ . ;
+]struct
diff --git a/fs/tests/all.fs b/fs/tests/all.fs
@@ -7,4 +7,5 @@ f<< /tests/asm/all.fs
f<< /tests/comp/c/all.fs
f<< /tests/ar/all.fs
f<< /tests/emul/all.fs
+f<< /tests/gr/all.fs
." All tests passed\n"
diff --git a/fs/tests/gr/all.fs b/fs/tests/gr/all.fs
@@ -0,0 +1 @@
+f<< /tests/gr/rect.fs
diff --git a/fs/tests/gr/rect.fs b/fs/tests/gr/rect.fs
@@ -0,0 +1,22 @@
+?f<< /tests/harness.fs
+?f<< /gr/rect.fs
+testbegin
+\ Testing gr/rect
+
+2 3 10 10 Rect :new structbind Rect r1
+6 5 10 10 Rect :new structbind Rect r2
+
+r1 :topleft 3 #eq 2 #eq
+r2 :bottomright 15 #eq 16 #eq
+r1 :null? 0 #eq
+42 5 r1 :haspoint? 0 #eq
+5 5 r1 :haspoint? 1 #eq
+r2 :self r1 :hasrect? 0 #eq
+5 5 2 2 Rect :tmpnew r1 :hasrect? 1 #eq
+r1 :self r1 :hasrect? 1 #eq
+r1 :self r2 :intersects? 1 #eq
+1 1 2 2 Rect :tmpnew r2 :intersects? 0 #eq
+r1 :self r2 :intersects? 1 #eq
+1 1 2 2 Rect :tmpnew r2 :intersection Rect :null? 1 #eq
+r1 :self r2 :intersection 6 5 6 8 Rect :tmpnew Rect := #
+testend
