135 lines
2.9 KiB
Factor
135 lines
2.9 KiB
Factor
|
! :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
|