--- /dev/null
+IN: scratchpad
+USE: graphics
+USE: test
+USE: namespaces
+USE: lists
+USE: kernel
+
+<rectangle> [
+ #{ 0 0 } from set
+ #{ 20 20 } to set
+] extend "rect" set
+
+[ t ] [ #{ 5 5 } "rect" get inside? ] unit-test
+[ f ] [ #{ 5 50 } "rect" get inside? ] unit-test
+[ f ] [ #{ 30 5 } "rect" get inside? ] unit-test
+
+<rectangle> [
+ #{ 10 15 } from set
+ #{ 20 35 } to set
+] extend "another-rect" set
+
+"rect" get "another-rect" get 2list "scene" set
+
+[ t ] [ #{ 5 5 } "scene" get grab "rect" get eq? ] unit-test
+[ t ] [ #{ 19 30 } "scene" get grab "another-rect" get eq? ] unit-test
+[ f ] [ #{ 50 50 } "scene" get grab ] unit-test
--- /dev/null
+! :sidekick.parser=none:
+
+IN: graphics
+
+USE: alien
+USE: combinators
+USE: errors
+USE: kernel
+USE: lists
+USE: logic
+USE: math
+USE: namespaces
+USE: sdl
+USE: stack
+USE: vectors
+USE: oop
+
+: black 0 0 0 255 rgba ;
+: white 255 255 255 255 rgba ;
+
+: clear-surface ( -- )
+ #! Crappy
+ surface get
+ NULL
+ surface get surface-format 255 255 255 SDL_MapRGB
+ SDL_FillRect drop ;
+
+! These variables are set in shape objects.
+SYMBOL: from ( complex number, x/y )
+SYMBOL: to ( complex number, w/h )
+SYMBOL: filled?
+SYMBOL: color
+SYMBOL: string ( text objects only )
+
+! Draw an object.
+GENERIC: draw ( obj -- )
+
+! Return if the point is inside the object.
+GENERIC: inside? ( #{ x y } obj -- ? )
+
+! Scale factor for all rendering, can be set in object too
+SYMBOL: scale
+
+! Translation
+SYMBOL: origin
+
+: center ( -- #{ x y } )
+ width get 2 / height get 2 / rect> ;
+
+: scene>screen ( #{ x y } -- #{ x y } )
+ origin get - scale get * center + ;
+
+: screen>scene ( #{ x y } -- #{ x y } )
+ center - scale get / origin get + ;
+
+: 2>irect >r >rect swap >fixnum swap >fixnum r> >rect swap >fixnum swap >fixnum ;
+
+: (rect) ( -- surface x y w h color )
+ surface get
+ from get scene>screen
+ to get scene>screen
+ 2>irect color get ;
+
+: in-rect? ( #{ x y } #{ x1 y1 } #{ x2 y2 } -- ? )
+ #! Return if x/y is in the rectangle bounded by x1/y1, x2/y2
+ 3dup
+ rot real rot real rot real between? >r
+ rot imaginary rot imaginary rot imaginary between? r> and ;
+
+TRAITS: rectangle
+M: rectangle draw ( -- )
+ (rect) filled? get [
+ boxColor
+ ] [
+ rectangleColor
+ ] ifte ;M
+
+M: rectangle inside? ( #{ x y } -- ? )
+ from get to get in-rect? ;M
+
+TRAITS: line
+M: line draw ( -- )
+ (rect) lineColor ;M
+
+M: line inside? ( #{ x y } -- ? )
+ from get to get in-rect? [
+ t
+ ] [
+ f
+ ] ifte ;M
+
+TRAITS: text
+M: text draw ( -- )
+ surface get from get >rect color get string get
+ stringColor ;M
+
+: grab ( #{ x y } list -- shape )
+ #! Return shape containing x/y.
+ dup [
+ 2dup car inside? [ nip car ] [ cdr grab ] ifte
+ ] [
+ 2drop f
+ ] ifte ;
--- /dev/null
+IN: scratchpad
+USE: test
+USE: namespaces
+USE: oop
+USE: stack
+
+TRAITS: test-traits
+
+[ t ] [ <test-traits> test-traits? ] unit-test
+[ f ] [ "hello" test-traits? ] unit-test
+[ f ] [ <namespace> test-traits? ] unit-test
+
+GENERIC: foo
+
+M: test-traits foo 12 ;M
+
+TRAITS: another-test
+
+M: another-test foo 13 ;M
+
+[ 12 ] [ <test-traits> foo ] unit-test
+[ 13 ] [ <another-test> foo ] unit-test
--- /dev/null
+! :sidekick.parser=none:
+IN: oop
+
+USE: combinators
+USE: errors
+USE: kernel
+USE: lists
+USE: namespaces
+USE: parser
+USE: stack
+USE: strings
+USE: words
+
+SYMBOL: traits
+
+: traits-map ( word -- hash )
+ #! The method map word property maps selector words to
+ #! definitions.
+ "traits-map" word-property ;
+
+: object-map ( obj -- hash )
+ dup has-namespace? [ traits swap get* ] [ drop f ] ifte ;
+
+: init-traits-map ( word -- )
+ <namespace> "traits-map" set-word-property ;
+
+: no-method
+ "No applicable method." throw ;
+
+: method ( traits selector -- quot )
+ #! Execute the method with the traits object on the stack.
+ over object-map get* [ [ no-method ] ] unless* ;
+
+: constructor-word ( word -- word )
+ word-name "<" swap ">" cat3 "in" get create ;
+
+: define-constructor ( word -- )
+ #! <foo> where foo is a traits type creates a new instance
+ #! of foo.
+ [ constructor-word [ <namespace> ] ] keep
+ traits-map [ traits pick set* ] cons append
+ define-compound ;
+
+: predicate-word ( word -- word )
+ word-name "?" cat2 "in" get create ;
+
+: define-predicate ( word -- )
+ #! foo? where foo is a traits type tests if the top of stack
+ #! is of this type.
+ dup predicate-word swap
+ [ object-map ] swap traits-map [ eq? ] cons append
+ define-compound ;
+
+: TRAITS:
+ #! TRAITS: foo creates a new traits type. Instances can be
+ #! created with <foo>, and tested with foo?.
+ CREATE
+ dup define-symbol
+ dup init-traits-map
+ dup define-constructor
+ define-predicate ; parsing
+
+: GENERIC:
+ #! GENERIC: bar creates a generic word bar that calls the
+ #! bar method on the traits object, with the traits object
+ #! on the namestack.
+ CREATE
+ dup unit [ car method bind ] cons
+ define-compound ; parsing
+
+: M:
+ #! M: foo bar begins a definition of the bar generic word
+ #! specialized to the foo type.
+ scan-word scan-word f ; parsing
+
+: ;M
+ #! ;M ends a method definition.
+ reverse transp traits-map set* ; parsing
--- /dev/null
+! :sidekick.parser=none:
+
+IN: graphics
+
+USE: combinators
+USE: errors
+USE: kernel
+USE: lists
+USE: logic
+USE: math
+USE: namespaces
+USE: sdl
+USE: stack
+USE: vectors
+USE: stdio
+USE: prettyprint
+USE: inspector
+
+SYMBOL: scene
+SYMBOL: tool
+SYMBOL: current ( shape we're drawing right now )
+SYMBOL: moving? ( are we moving or resizing current shape? )
+SYMBOL: buttons ( mouse buttons down )
+SYMBOL: clicked ( mouse click location )
+
+: ch>tool ( ch -- quot )
+ [
+ [ CHAR: a ]
+ [ CHAR: r <rectangle> ]
+ [ CHAR: l <line> ]
+ ] assoc ;
+
+: render ( -- )
+ clear-surface
+ scene get [ draw ] each
+ current get [ draw ] when* ;
+
+: mouse-xy ( mouse-event -- #{ x y } )
+ dup motion-event-x swap motion-event-y rect> ;
+
+: begin-draw ( #{ x y } -- )
+ tool get call [
+ dup from set to set
+ black color set
+ ] extend current set ;
+
+: begin-move ( #{ x y } -- )
+ scene get grab
+ [ dup scene remove@ current set moving? on ] when* ;
+
+: button-down ( event -- )
+ button-event-button buttons unique@ ;
+
+: mouse-down-event ( event -- )
+ dup button-down
+ 1 buttons get contains? [
+ mouse-xy screen>scene tool get [ begin-draw ] [ begin-move ] ifte
+ ] [
+ drop
+ ] ifte ;
+
+: button-up ( event -- )
+ button-event-button buttons remove@ ;
+
+: mouse-up-event ( event -- )
+ button-up
+ current get [
+ scene cons@ current off moving? off
+ ] when* ;
+
+: mouse-delta ( mouse-event -- #{ x y } )
+ dup motion-event-xrel swap motion-event-yrel rect> ;
+
+: mouse-motion-event ( event -- )
+ 2 buttons get contains? [
+ mouse-delta scale get / origin -@
+ ] [
+ current get dup [
+ [
+ moving? get [
+ mouse-delta scale get / dup from +@ to +@
+ ] [
+ mouse-xy screen>scene to set
+ ] ifte
+ ] bind
+ ] [
+ 2drop
+ ] ifte
+ ] ifte ;
+
+: key-down-event
+ keyboard-event-sym [
+ [ CHAR: - = ] [ drop 1.1 scale /@ ]
+ [ CHAR: = = ] [ drop 1.1 scale *@ ]
+ [ drop t ] [ ch>tool tool set ]
+ ] cond ;
+
+: debug-event ( event -- ? )
+ [
+ [ event-type SDL_MOUSEBUTTONDOWN = ] [ mouse-down-event t ]
+ [ event-type SDL_MOUSEBUTTONUP = ] [ mouse-up-event t ]
+ [ event-type SDL_MOUSEMOTION = ] [ mouse-motion-event t ]
+ [ event-type SDL_KEYDOWN = ] [ key-down-event t ]
+ [ event-type SDL_QUIT = ] [ drop f ]
+ [ drop t ] [ drop t ]
+ ] cond ;
+
+: debug-event-loop ( event -- )
+ dup SDL_WaitEvent 1 = [
+ dup debug-event [
+ [ render ] with-surface
+ debug-event-loop
+ ] [
+ drop
+ ] ifte
+ ] [
+ drop
+ ] ifte ;
+
+: zui-test ( -- )
+ 640 480 32 SDL_HWSURFACE SDL_SetVideoMode drop
+ 1 scale set
+ 0 origin set
+ buttons off
+ 640 width set
+ 480 height set
+
+ scene off
+ [ <line> ] tool set
+
+ <event> debug-event-loop
+ SDL_Quit ;
+
+zui-test
projects / factor.git / commitdiff