halos
parent
175b211160
commit
c4da07c80d
|
@ -17,7 +17,7 @@
|
||||||
- console: scroll to bottom
|
- console: scroll to bottom
|
||||||
- split preferred size and layouting
|
- split preferred size and layouting
|
||||||
- remove shelf/pile duplication
|
- remove shelf/pile duplication
|
||||||
- resizing and moving gadgets
|
- resizing gadgets
|
||||||
- faster layout
|
- faster layout
|
||||||
- faster repaint
|
- faster repaint
|
||||||
- closing inspectors
|
- closing inspectors
|
||||||
|
|
|
@ -82,21 +82,11 @@ SYMBOL: meta-cf
|
||||||
: do-1 ( obj -- )
|
: do-1 ( obj -- )
|
||||||
dup word? [ meta-word-1 ] [ push-d ] ifte ;
|
dup word? [ meta-word-1 ] [ push-d ] ifte ;
|
||||||
|
|
||||||
: (interpret) ( quot -- )
|
: interpret ( quot -- )
|
||||||
#! The quotation is called with each word as its executed.
|
#! The quotation is called with each word as its executed.
|
||||||
done? [ drop ] [ [ next swap call ] keep (interpret) ] ifte ;
|
done? [ drop ] [ [ next swap call ] keep interpret ] ifte ;
|
||||||
|
|
||||||
: interpret ( quot quot -- )
|
: run ( -- ) [ do ] interpret ;
|
||||||
#! The first quotation is meta-interpreted, with each word
|
|
||||||
#! passed to the second quotation. Pollutes current
|
|
||||||
#! namespace.
|
|
||||||
init-interpreter swap meta-cf set (interpret) ;
|
|
||||||
|
|
||||||
: (run) ( -- )
|
|
||||||
[ do ] (interpret) ;
|
|
||||||
|
|
||||||
: run ( quot -- )
|
|
||||||
[ do ] interpret ;
|
|
||||||
|
|
||||||
: set-meta-word ( word quot -- )
|
: set-meta-word ( word quot -- )
|
||||||
"meta-word" set-word-property ;
|
"meta-word" set-word-property ;
|
||||||
|
@ -117,23 +107,6 @@ SYMBOL: meta-cf
|
||||||
|
|
||||||
! Some useful tools
|
! Some useful tools
|
||||||
|
|
||||||
: report ( obj -- )
|
|
||||||
meta-r get vector-length " " fill write . flush ;
|
|
||||||
|
|
||||||
: (trace) ( -- )
|
|
||||||
[ dup report do ] (interpret) ;
|
|
||||||
|
|
||||||
: trace ( quot -- )
|
|
||||||
#! Trace execution of a quotation by printing each word as
|
|
||||||
#! its executed, and each literal as its pushed. Each line
|
|
||||||
#! is indented by the call stack height.
|
|
||||||
[
|
|
||||||
init-interpreter
|
|
||||||
meta-cf set
|
|
||||||
(trace)
|
|
||||||
meta-d get set-datastack
|
|
||||||
] with-scope ;
|
|
||||||
|
|
||||||
: &s
|
: &s
|
||||||
#! Print stepper data stack.
|
#! Print stepper data stack.
|
||||||
meta-d get {.} ;
|
meta-d get {.} ;
|
||||||
|
@ -154,19 +127,27 @@ SYMBOL: meta-cf
|
||||||
#! Print stepper variable value.
|
#! Print stepper variable value.
|
||||||
meta-n get (get) ;
|
meta-n get (get) ;
|
||||||
|
|
||||||
: not-done ( quot -- )
|
: stack-report ( -- )
|
||||||
done? [ "Stepper is done." print drop ] [ call ] ifte ;
|
meta-r get vector-length "=" fill write
|
||||||
|
meta-d get vector-length "-" fill write ;
|
||||||
|
|
||||||
: next-report ( -- obj )
|
: not-done ( quot -- )
|
||||||
next dup report meta-cf get report ;
|
done? [
|
||||||
|
stack-report "Stepper is done." print drop
|
||||||
|
] [
|
||||||
|
call
|
||||||
|
] ifte ;
|
||||||
|
|
||||||
|
: report ( -- )
|
||||||
|
stack-report meta-cf get . ;
|
||||||
|
|
||||||
: step
|
: step
|
||||||
#! Step into current word.
|
#! Step into current word.
|
||||||
[ next-report do-1 ] not-done ;
|
[ next do-1 report ] not-done ;
|
||||||
|
|
||||||
: into
|
: into
|
||||||
#! Step into current word.
|
#! Step into current word.
|
||||||
[ next-report do ] not-done ;
|
[ next do report ] not-done ;
|
||||||
|
|
||||||
: walk-banner ( -- )
|
: walk-banner ( -- )
|
||||||
"The following words control the single-stepper:" print
|
"The following words control the single-stepper:" print
|
||||||
|
@ -176,9 +157,9 @@ SYMBOL: meta-cf
|
||||||
" ( var -- value ) inspects the stepper namestack." print
|
" ( var -- value ) inspects the stepper namestack." print
|
||||||
\ step prettyprint-word " -- single step over" print
|
\ step prettyprint-word " -- single step over" print
|
||||||
\ into prettyprint-word " -- single step into" print
|
\ into prettyprint-word " -- single step into" print
|
||||||
\ (trace) prettyprint-word " -- trace until end" print
|
\ run prettyprint-word " -- run until end" print
|
||||||
\ (run) prettyprint-word " -- run until end" print
|
\ exit prettyprint-word " -- exit single-stepper" print
|
||||||
\ exit prettyprint-word " -- exit single-stepper" print ;
|
report ;
|
||||||
|
|
||||||
: walk ( quot -- )
|
: walk ( quot -- )
|
||||||
#! Single-step through execution of a quotation.
|
#! Single-step through execution of a quotation.
|
||||||
|
|
|
@ -4,17 +4,16 @@ IN: gadgets
|
||||||
USING: generic kernel lists math namespaces prettyprint sdl
|
USING: generic kernel lists math namespaces prettyprint sdl
|
||||||
stdio ;
|
stdio ;
|
||||||
|
|
||||||
: button-down? ( n -- ? )
|
: button-down? ( n -- ? ) hand hand-buttons contains? ;
|
||||||
my-hand hand-buttons contains? ;
|
|
||||||
|
|
||||||
: mouse-over? ( gadget -- ? ) my-hand hand-gadget child? ;
|
: mouse-over? ( gadget -- ? ) hand hand-gadget child? ;
|
||||||
|
|
||||||
: button-pressed? ( button -- ? )
|
: button-pressed? ( button -- ? )
|
||||||
#! Return true if the mouse was clicked on the button, and
|
#! Return true if the mouse was clicked on the button, and
|
||||||
#! is currently over the button.
|
#! is currently over the button.
|
||||||
dup mouse-over? [
|
dup mouse-over? [
|
||||||
1 button-down? [
|
1 button-down? [
|
||||||
my-hand hand-clicked child?
|
hand hand-clicked child?
|
||||||
] [
|
] [
|
||||||
drop f
|
drop f
|
||||||
] ifte
|
] ifte
|
||||||
|
|
|
@ -20,7 +20,6 @@ TUPLE: dialog continuation delegate ;
|
||||||
<button> over add-gadget ;
|
<button> over add-gadget ;
|
||||||
|
|
||||||
: dialog-actions ( dialog -- )
|
: dialog-actions ( dialog -- )
|
||||||
dup moving-actions
|
|
||||||
dup [ dialog-ok ] dup set-action
|
dup [ dialog-ok ] dup set-action
|
||||||
[ dialog-cancel ] dup set-action ;
|
[ dialog-cancel ] dup set-action ;
|
||||||
|
|
||||||
|
|
|
@ -50,7 +50,7 @@ TUPLE: editor line caret delegate ;
|
||||||
[ line-text get x>offset caret set ] with-editor ;
|
[ line-text get x>offset caret set ] with-editor ;
|
||||||
|
|
||||||
: click-editor ( editor -- )
|
: click-editor ( editor -- )
|
||||||
my-hand
|
hand
|
||||||
2dup relative shape-x pick set-caret-x
|
2dup relative shape-x pick set-caret-x
|
||||||
request-focus ;
|
request-focus ;
|
||||||
|
|
||||||
|
|
|
@ -19,29 +19,29 @@ M: resize-event handle-event ( event -- )
|
||||||
world get relayout ;
|
world get relayout ;
|
||||||
|
|
||||||
: button-gesture ( button gesture -- [ gesture button ] )
|
: button-gesture ( button gesture -- [ gesture button ] )
|
||||||
swap unit append my-hand hand-clicked handle-gesture drop ;
|
swap unit append hand hand-clicked handle-gesture drop ;
|
||||||
|
|
||||||
M: button-down-event handle-event ( event -- )
|
M: button-down-event handle-event ( event -- )
|
||||||
button-event-button dup my-hand button/
|
button-event-button dup hand button/
|
||||||
[ button-down ] button-gesture ;
|
[ button-down ] button-gesture ;
|
||||||
|
|
||||||
M: button-up-event handle-event ( event -- )
|
M: button-up-event handle-event ( event -- )
|
||||||
button-event-button dup my-hand button\
|
button-event-button dup hand button\
|
||||||
[ button-up ] button-gesture ;
|
[ button-up ] button-gesture ;
|
||||||
|
|
||||||
: motion-event-pos ( event -- x y )
|
: motion-event-pos ( event -- x y )
|
||||||
dup motion-event-x swap motion-event-y ;
|
dup motion-event-x swap motion-event-y ;
|
||||||
|
|
||||||
M: motion-event handle-event ( event -- )
|
M: motion-event handle-event ( event -- )
|
||||||
motion-event-pos my-hand move-hand ;
|
motion-event-pos hand move-hand ;
|
||||||
|
|
||||||
M: key-down-event handle-event ( event -- )
|
M: key-down-event handle-event ( event -- )
|
||||||
dup keyboard-event>binding
|
dup keyboard-event>binding
|
||||||
my-hand hand-focus handle-gesture [
|
hand hand-focus handle-gesture [
|
||||||
keyboard-event-unicode dup 0 = [
|
keyboard-event-unicode dup 0 = [
|
||||||
drop
|
drop
|
||||||
] [
|
] [
|
||||||
my-hand hand-focus user-input drop
|
hand hand-focus user-input drop
|
||||||
] ifte
|
] ifte
|
||||||
] [
|
] [
|
||||||
drop
|
drop
|
||||||
|
|
|
@ -11,12 +11,15 @@ TUPLE: gadget
|
||||||
relayout? redraw?
|
relayout? redraw?
|
||||||
parent children delegate ;
|
parent children delegate ;
|
||||||
|
|
||||||
|
DEFER: default-actions
|
||||||
|
|
||||||
C: gadget ( shape -- gadget )
|
C: gadget ( shape -- gadget )
|
||||||
[ set-gadget-delegate ] keep
|
[ set-gadget-delegate ] keep
|
||||||
[ <namespace> swap set-gadget-paint ] keep
|
[ <namespace> swap set-gadget-paint ] keep
|
||||||
[ <namespace> swap set-gadget-gestures ] keep
|
[ <namespace> swap set-gadget-gestures ] keep
|
||||||
[ t swap set-gadget-relayout? ] keep
|
[ t swap set-gadget-relayout? ] keep
|
||||||
[ t swap set-gadget-redraw? ] keep ;
|
[ t swap set-gadget-redraw? ] keep
|
||||||
|
dup default-actions ;
|
||||||
|
|
||||||
: <empty-gadget> ( -- gadget )
|
: <empty-gadget> ( -- gadget )
|
||||||
0 0 0 0 <rectangle> <gadget> ;
|
0 0 0 0 <rectangle> <gadget> ;
|
||||||
|
|
|
@ -1,20 +1,59 @@
|
||||||
! Copyright (C) 2005 Slava Pestov.
|
! Copyright (C) 2005 Slava Pestov.
|
||||||
! See http://factor.sf.net/license.txt for BSD license.
|
! See http://factor.sf.net/license.txt for BSD license.
|
||||||
IN: gadgets
|
IN: gadgets
|
||||||
USING: kernel math namespaces sdl ;
|
USING: kernel math namespaces prettyprint sdl ;
|
||||||
|
|
||||||
! The halo is used to move and resize gadgets.
|
TUPLE: halo selected delegate ;
|
||||||
|
|
||||||
: grab ( gadget hand -- )
|
: gadget-menu ( gadget -- assoc )
|
||||||
[ swap screen-pos swap screen-pos - >rect ] 2keep
|
[
|
||||||
>r [ move-gadget ] keep r> add-gadget ;
|
[[ "Inspect" [ inspect ] ]]
|
||||||
|
[[ "Unparent" [ unparent ] ]]
|
||||||
|
[[ "Move" [ hand grab ] ]]
|
||||||
|
] actionize ;
|
||||||
|
|
||||||
: release ( gadget world -- )
|
: halo-menu ( halo -- )
|
||||||
>r dup screen-pos >r dup unparent
|
halo-selected gadget-menu <menu> show-menu ;
|
||||||
r> >rect pick move-gadget
|
|
||||||
r> add-gadget ;
|
: show-halo* ( gadget -- )
|
||||||
|
#! Show the halo on a specific gadget.
|
||||||
|
halo
|
||||||
|
[ world get add-gadget ] keep
|
||||||
|
[ set-halo-selected ] keep relayout ;
|
||||||
|
|
||||||
|
: hide-halo ( -- )
|
||||||
|
halo f over set-halo-selected unparent ;
|
||||||
|
|
||||||
|
: parent-selected? ( gadget halo -- ? )
|
||||||
|
#! See if the parent of a gadget is selected with a halo.
|
||||||
|
halo-selected dup [ swap child? ] [ 2drop f ] ifte ;
|
||||||
|
|
||||||
|
: show-halo ( gadget -- )
|
||||||
|
#! If a halo is already showing on the gadget, go to the
|
||||||
|
#! parent.
|
||||||
|
halo halo-selected world get eq? [
|
||||||
|
drop hide-halo
|
||||||
|
] [
|
||||||
|
dup halo parent-selected? [
|
||||||
|
drop halo halo-selected gadget-parent
|
||||||
|
] when show-halo*
|
||||||
|
] ifte ;
|
||||||
|
|
||||||
|
: halo-actions ( gadget -- )
|
||||||
|
dup [ halo-selected hand grab ] [ button-down 1 ] set-action
|
||||||
|
dup [ halo-selected show-halo ] [ button-down 2 ] set-action
|
||||||
|
[ halo-menu ] [ button-down 3 ] set-action ;
|
||||||
|
|
||||||
|
C: halo ( -- halo )
|
||||||
|
0 0 0 0 <hollow-rect> <gadget> over set-halo-delegate
|
||||||
|
dup red foreground set-paint-property
|
||||||
|
dup halo-actions ;
|
||||||
|
|
||||||
|
M: halo layout* ( halo -- )
|
||||||
|
dup halo-selected
|
||||||
|
2dup screen-pos >rect rot move-gadget
|
||||||
|
dup shape-w swap shape-h rot resize-gadget ;
|
||||||
|
|
||||||
|
: default-actions ( gadget -- )
|
||||||
|
[ show-halo ] [ button-down 2 ] set-action ;
|
||||||
|
|
||||||
: moving-actions ( gadget -- )
|
|
||||||
dup
|
|
||||||
[ my-hand grab ] [ button-down 1 ] set-action
|
|
||||||
[ world get release ] [ button-up 1 ] set-action ;
|
|
||||||
|
|
|
@ -1,8 +1,8 @@
|
||||||
! Copyright (C) 2005 Slava Pestov.
|
! Copyright (C) 2005 Slava Pestov.
|
||||||
! See http://factor.sf.net/license.txt for BSD license.
|
! See http://factor.sf.net/license.txt for BSD license.
|
||||||
IN: gadgets
|
IN: gadgets
|
||||||
USING: alien generic kernel lists math namespaces sdl sdl-event
|
USING: alien generic kernel lists math namespaces prettyprint
|
||||||
sdl-video ;
|
sdl sdl-event sdl-video stdio ;
|
||||||
|
|
||||||
DEFER: pick-up
|
DEFER: pick-up
|
||||||
|
|
||||||
|
@ -50,12 +50,34 @@ TUPLE: hand
|
||||||
click-pos clicked buttons
|
click-pos clicked buttons
|
||||||
gadget focus delegate ;
|
gadget focus delegate ;
|
||||||
|
|
||||||
|
: grab ( gadget hand -- )
|
||||||
|
#! Grab hold of a gadget; the gadget will move with the
|
||||||
|
#! hand.
|
||||||
|
2dup set-hand-clicked
|
||||||
|
[ swap screen-pos swap screen-pos - >rect ] 2keep
|
||||||
|
>r [ move-gadget ] keep r> add-gadget ;
|
||||||
|
|
||||||
|
: release* ( gadget world -- )
|
||||||
|
>r dup screen-pos >r dup unparent
|
||||||
|
r> >rect pick move-gadget
|
||||||
|
r> add-gadget ;
|
||||||
|
|
||||||
|
: release ( hand -- )
|
||||||
|
#! Release the gadget we are holding.
|
||||||
|
dup gadget-children car swap hand-world release* ;
|
||||||
|
|
||||||
|
: hand-actions ( hand -- )
|
||||||
|
#! A nice trick is that the hand is only consulted for
|
||||||
|
#! gestures when one of its children is clicked.
|
||||||
|
[ release ] [ button-up 1 ] set-action ;
|
||||||
|
|
||||||
C: hand ( world -- hand )
|
C: hand ( world -- hand )
|
||||||
<empty-gadget>
|
<empty-gadget>
|
||||||
over set-hand-delegate
|
over set-hand-delegate
|
||||||
[ set-hand-world ] 2keep
|
[ set-hand-world ] 2keep
|
||||||
[ set-gadget-parent ] 2keep
|
[ set-gadget-parent ] 2keep
|
||||||
[ set-hand-gadget ] keep ;
|
[ set-hand-gadget ] keep
|
||||||
|
[ hand-actions ] keep ;
|
||||||
|
|
||||||
: button/ ( n hand -- )
|
: button/ ( n hand -- )
|
||||||
dup hand-gadget over set-hand-clicked
|
dup hand-gadget over set-hand-clicked
|
||||||
|
@ -71,9 +93,16 @@ C: hand ( world -- hand )
|
||||||
: fire-enter ( oldpos hand -- )
|
: fire-enter ( oldpos hand -- )
|
||||||
hand-gadget [ screen-pos - ] keep mouse-enter ;
|
hand-gadget [ screen-pos - ] keep mouse-enter ;
|
||||||
|
|
||||||
: update-hand-gadget ( hand -- )
|
: find-hand-gadget ( hand -- gadget )
|
||||||
#! The hand gadget is the gadget under the hand right now.
|
#! The hand gadget is the gadget under the hand right now.
|
||||||
dup dup hand-world pick-up swap set-hand-gadget ;
|
dup gadget-children [ dup hand-world pick-up ] unless ;
|
||||||
|
|
||||||
|
: update-hand-gadget ( hand -- )
|
||||||
|
dup find-hand-gadget swap set-hand-gadget ;
|
||||||
|
|
||||||
|
: motion-gesture ( hand gadget gesture -- )
|
||||||
|
#! Send a gesture like [ drag 2 ].
|
||||||
|
rot hand-buttons car unit append swap handle-gesture drop ;
|
||||||
|
|
||||||
: fire-motion ( hand -- )
|
: fire-motion ( hand -- )
|
||||||
#! Fire a motion gesture to the gadget underneath the hand,
|
#! Fire a motion gesture to the gadget underneath the hand,
|
||||||
|
@ -81,7 +110,7 @@ C: hand ( world -- hand )
|
||||||
#! gadget that was clicked.
|
#! gadget that was clicked.
|
||||||
[ motion ] over hand-gadget handle-gesture drop
|
[ motion ] over hand-gadget handle-gesture drop
|
||||||
dup hand-buttons [
|
dup hand-buttons [
|
||||||
[ drag ] swap hand-clicked handle-gesture drop
|
dup hand-clicked [ drag ] motion-gesture
|
||||||
] [
|
] [
|
||||||
drop
|
drop
|
||||||
] ifte ;
|
] ifte ;
|
||||||
|
|
|
@ -43,18 +43,18 @@ GENERIC: custom-sheet ( obj -- gadget )
|
||||||
over top-sheet over add-gadget
|
over top-sheet over add-gadget
|
||||||
over slot-sheet over add-gadget
|
over slot-sheet over add-gadget
|
||||||
swap custom-sheet over add-gadget
|
swap custom-sheet over add-gadget
|
||||||
line-border dup moving-actions ;
|
line-border ;
|
||||||
|
|
||||||
M: object custom-sheet drop <empty-gadget> ;
|
M: object custom-sheet drop <empty-gadget> ;
|
||||||
|
|
||||||
|
M: list custom-sheet ( list -- gadget )
|
||||||
|
[ length count ] keep zip alist>sheet "Elements:" <titled> ;
|
||||||
|
|
||||||
M: array custom-sheet ( array -- gadget )
|
M: array custom-sheet ( array -- gadget )
|
||||||
[ array-capacity [ count ] keep ] keep array>list zip
|
[ array-capacity ] keep array>list custom-sheet ;
|
||||||
alist>sheet
|
|
||||||
"Elements:" <titled> ;
|
|
||||||
|
|
||||||
M: vector custom-sheet ( array -- gadget )
|
M: vector custom-sheet ( array -- gadget )
|
||||||
dup vector-length count swap vector>list zip alist>sheet
|
vector>list custom-sheet ;
|
||||||
"Elements:" <titled> ;
|
|
||||||
|
|
||||||
M: hashtable custom-sheet ( array -- gadget )
|
M: hashtable custom-sheet ( array -- gadget )
|
||||||
hash>alist sort-sheet alist>sheet "Entries:" <titled> ;
|
hash>alist sort-sheet alist>sheet "Entries:" <titled> ;
|
||||||
|
|
|
@ -41,3 +41,10 @@ C: menu ( assoc -- gadget )
|
||||||
! While a menu is open, clicking anywhere sends the click to
|
! While a menu is open, clicking anywhere sends the click to
|
||||||
! the menu.
|
! the menu.
|
||||||
M: menu inside? ( point menu -- ? ) 2drop t ;
|
M: menu inside? ( point menu -- ? ) 2drop t ;
|
||||||
|
|
||||||
|
: actionize ( obj assoc -- assoc )
|
||||||
|
#! Prepends an object to each cdr of the assoc list. Utility
|
||||||
|
#! word for constructing menu action association lists.
|
||||||
|
[
|
||||||
|
unswons >r >r unit [ car ] cons r> append r> swons
|
||||||
|
] map-with ;
|
||||||
|
|
|
@ -5,11 +5,6 @@ USING: kernel lists namespaces prettyprint stdio unparser ;
|
||||||
|
|
||||||
DEFER: inspect
|
DEFER: inspect
|
||||||
|
|
||||||
: actionize ( obj assoc -- assoc )
|
|
||||||
[
|
|
||||||
unswons >r >r unit [ car ] cons r> append r> swons
|
|
||||||
] map-with ;
|
|
||||||
|
|
||||||
: object-menu ( obj -- assoc )
|
: object-menu ( obj -- assoc )
|
||||||
[
|
[
|
||||||
[[ "Inspect" [ inspect ] ]]
|
[[ "Inspect" [ inspect ] ]]
|
||||||
|
|
|
@ -9,7 +9,7 @@ SYMBOL: root-menu
|
||||||
root-menu get <menu> show-menu ;
|
root-menu get <menu> show-menu ;
|
||||||
|
|
||||||
: <console> ( -- console )
|
: <console> ( -- console )
|
||||||
<console-pane> <scroller> line-border dup moving-actions ;
|
<console-pane> <scroller> line-border ;
|
||||||
|
|
||||||
[
|
[
|
||||||
[[ "Listener" [ <console> world get add-gadget ] ]]
|
[[ "Listener" [ <console> world get add-gadget ] ]]
|
||||||
|
|
|
@ -57,7 +57,7 @@ TUPLE: thumb offset delegate ;
|
||||||
|
|
||||||
: hand-y ( gadget -- y )
|
: hand-y ( gadget -- y )
|
||||||
#! Vertical offset of hand from gadget.
|
#! Vertical offset of hand from gadget.
|
||||||
my-hand swap relative shape-y ;
|
hand swap relative shape-y ;
|
||||||
|
|
||||||
: thumb-click ( thumb -- )
|
: thumb-click ( thumb -- )
|
||||||
[ hand-y ] keep set-thumb-offset ;
|
[ hand-y ] keep set-thumb-offset ;
|
||||||
|
@ -73,7 +73,7 @@ TUPLE: thumb offset delegate ;
|
||||||
: thumb-actions ( thumb -- )
|
: thumb-actions ( thumb -- )
|
||||||
dup
|
dup
|
||||||
[ thumb-click ] [ button-down 1 ] set-action
|
[ thumb-click ] [ button-down 1 ] set-action
|
||||||
[ thumb-motion ] [ drag ] set-action ;
|
[ thumb-motion ] [ drag 1 ] set-action ;
|
||||||
|
|
||||||
C: thumb ( -- thumb )
|
C: thumb ( -- thumb )
|
||||||
0 0 0 0 <plain-rect> <gadget> over set-thumb-delegate
|
0 0 0 0 <plain-rect> <gadget> over set-thumb-delegate
|
||||||
|
|
|
@ -2,13 +2,13 @@
|
||||||
! See http://factor.sf.net/license.txt for BSD license.
|
! See http://factor.sf.net/license.txt for BSD license.
|
||||||
IN: gadgets
|
IN: gadgets
|
||||||
USING: alien errors generic kernel lists math memory namespaces
|
USING: alien errors generic kernel lists math memory namespaces
|
||||||
sdl sdl-event sdl-video stdio strings threads ;
|
prettyprint sdl sdl-event sdl-video stdio strings threads ;
|
||||||
|
|
||||||
! The world gadget is the top level gadget that all (visible)
|
! The world gadget is the top level gadget that all (visible)
|
||||||
! gadgets are contained in. The current world is stored in the
|
! gadgets are contained in. The current world is stored in the
|
||||||
! world variable. The menu slot ensures that only one menu is
|
! world variable. The menu slot ensures that only one menu is
|
||||||
! open at any one time.
|
! open at any one time.
|
||||||
TUPLE: world running? hand menu delegate ;
|
TUPLE: world running? hand menu halo delegate ;
|
||||||
|
|
||||||
: <world-box> ( -- box )
|
: <world-box> ( -- box )
|
||||||
0 0 0 0 <plain-rect> <gadget> ;
|
0 0 0 0 <plain-rect> <gadget> ;
|
||||||
|
@ -16,11 +16,13 @@ TUPLE: world running? hand menu delegate ;
|
||||||
C: world ( -- world )
|
C: world ( -- world )
|
||||||
<world-box> over set-world-delegate
|
<world-box> over set-world-delegate
|
||||||
t over set-world-running?
|
t over set-world-running?
|
||||||
dup <hand> over set-world-hand ;
|
dup <hand> over set-world-hand
|
||||||
|
dup <halo> over set-world-halo ;
|
||||||
|
|
||||||
M: world inside? ( point world -- ? ) 2drop t ;
|
M: world inside? ( point world -- ? ) 2drop t ;
|
||||||
|
|
||||||
: my-hand ( -- hand ) world get world-hand ;
|
: hand world get world-hand ;
|
||||||
|
: halo world get world-halo ;
|
||||||
|
|
||||||
: draw-world ( world -- )
|
: draw-world ( world -- )
|
||||||
dup gadget-redraw? [
|
dup gadget-redraw? [
|
||||||
|
@ -35,10 +37,21 @@ M: world inside? ( point world -- ? ) 2drop t ;
|
||||||
|
|
||||||
DEFER: handle-event
|
DEFER: handle-event
|
||||||
|
|
||||||
|
: layout-halo ( world -- )
|
||||||
|
world-halo dup halo-selected dup [
|
||||||
|
dup gadget-parent [
|
||||||
|
drop dup gadget-parent [ relayout ] [ drop ] ifte
|
||||||
|
] [
|
||||||
|
unparent drop
|
||||||
|
] ifte
|
||||||
|
] [
|
||||||
|
2drop
|
||||||
|
] ifte ;
|
||||||
|
|
||||||
: layout-world ( world -- )
|
: layout-world ( world -- )
|
||||||
dup
|
dup
|
||||||
0 0 width get height get <rectangle> clip set-paint-property
|
0 0 width get height get <rectangle> clip set-paint-property
|
||||||
dup layout world-hand update-hand ;
|
dup layout-halo dup layout world-hand update-hand ;
|
||||||
|
|
||||||
: world-step ( world -- ? )
|
: world-step ( world -- ? )
|
||||||
dup world-running? [
|
dup world-running? [
|
||||||
|
|
|
@ -2,13 +2,8 @@
|
||||||
|
|
||||||
void primitive_arithmetic_type(void)
|
void primitive_arithmetic_type(void)
|
||||||
{
|
{
|
||||||
CELL obj1 = dpeek();
|
CELL obj1 = dpeek(), obj2 = get(ds - CELLS);
|
||||||
CELL obj2 = get(ds - CELLS);
|
CELL type1 = TAG(obj1), type2 = TAG(obj2);
|
||||||
|
|
||||||
CELL type1 = TAG(obj1);
|
|
||||||
CELL type2 = TAG(obj2);
|
|
||||||
|
|
||||||
CELL type;
|
|
||||||
|
|
||||||
switch(type2)
|
switch(type2)
|
||||||
{
|
{
|
||||||
|
@ -22,72 +17,64 @@ void primitive_arithmetic_type(void)
|
||||||
put(ds - CELLS,tag_float(to_float((obj2))));
|
put(ds - CELLS,tag_float(to_float((obj2))));
|
||||||
break;
|
break;
|
||||||
}
|
}
|
||||||
type = type1;
|
dpush(tag_fixnum(type1));
|
||||||
break;
|
break;
|
||||||
case BIGNUM_TYPE:
|
case BIGNUM_TYPE:
|
||||||
switch(type1)
|
switch(type1)
|
||||||
{
|
{
|
||||||
case FIXNUM_TYPE:
|
case FIXNUM_TYPE:
|
||||||
drepl(tag_bignum(to_bignum(obj1)));
|
drepl(tag_bignum(to_bignum(obj1)));
|
||||||
type = type2;
|
dpush(tag_fixnum(type2));
|
||||||
break;
|
break;
|
||||||
case FLOAT_TYPE:
|
case FLOAT_TYPE:
|
||||||
put(ds - CELLS,tag_float(to_float((obj2))));
|
put(ds - CELLS,tag_float(to_float((obj2))));
|
||||||
type = type1;
|
dpush(tag_fixnum(type1));
|
||||||
break;
|
break;
|
||||||
default:
|
default:
|
||||||
type = type1;
|
dpush(tag_fixnum(type1));
|
||||||
break;
|
break;
|
||||||
}
|
}
|
||||||
break;
|
break;
|
||||||
case RATIO_TYPE:
|
case RATIO_TYPE:
|
||||||
switch(type1)
|
switch(type1)
|
||||||
{
|
{
|
||||||
case FIXNUM_TYPE:
|
case FIXNUM_TYPE: case BIGNUM_TYPE:
|
||||||
case BIGNUM_TYPE:
|
dpush(tag_fixnum(type2));
|
||||||
type = type2;
|
|
||||||
break;
|
break;
|
||||||
case FLOAT_TYPE:
|
case FLOAT_TYPE:
|
||||||
put(ds - CELLS,tag_float(to_float((obj2))));
|
put(ds - CELLS,tag_float(to_float((obj2))));
|
||||||
type = type1;
|
dpush(tag_fixnum(type1));
|
||||||
break;
|
break;
|
||||||
default:
|
default:
|
||||||
type = type1;
|
dpush(tag_fixnum(type1));
|
||||||
break;
|
break;
|
||||||
}
|
}
|
||||||
break;
|
break;
|
||||||
case FLOAT_TYPE:
|
case FLOAT_TYPE:
|
||||||
switch(type1)
|
switch(type1)
|
||||||
{
|
{
|
||||||
case FIXNUM_TYPE:
|
case FIXNUM_TYPE: case BIGNUM_TYPE: case RATIO_TYPE:
|
||||||
case BIGNUM_TYPE:
|
|
||||||
case RATIO_TYPE:
|
|
||||||
drepl(tag_float(to_float(obj1)));
|
drepl(tag_float(to_float(obj1)));
|
||||||
type = type2;
|
dpush(tag_fixnum(type2));
|
||||||
break;
|
break;
|
||||||
default:
|
default:
|
||||||
type = type1;
|
dpush(tag_fixnum(type1));
|
||||||
break;
|
break;
|
||||||
}
|
}
|
||||||
break;
|
break;
|
||||||
case COMPLEX_TYPE:
|
case COMPLEX_TYPE:
|
||||||
switch(type1)
|
switch(type1)
|
||||||
{
|
{
|
||||||
case FIXNUM_TYPE:
|
case FIXNUM_TYPE: case BIGNUM_TYPE: case RATIO_TYPE: case FLOAT_TYPE:
|
||||||
case BIGNUM_TYPE:
|
dpush(tag_fixnum(type2));
|
||||||
case RATIO_TYPE:
|
|
||||||
case FLOAT_TYPE:
|
|
||||||
type = type2;
|
|
||||||
break;
|
break;
|
||||||
default:
|
default:
|
||||||
type = type1;
|
dpush(tag_fixnum(type1));
|
||||||
break;
|
break;
|
||||||
}
|
}
|
||||||
break;
|
break;
|
||||||
default:
|
default:
|
||||||
type = type2;
|
dpush(tag_fixnum(type2));
|
||||||
break;
|
break;
|
||||||
}
|
}
|
||||||
|
|
||||||
dpush(tag_fixnum(type));
|
|
||||||
}
|
}
|
||||||
|
|
|
@ -1,24 +1,17 @@
|
||||||
#include "factor.h"
|
#include "factor.h"
|
||||||
|
|
||||||
/* untagged */
|
|
||||||
F_ARRAY* allot_array(CELL type, CELL capacity)
|
F_ARRAY* allot_array(CELL type, CELL capacity)
|
||||||
{
|
{
|
||||||
F_ARRAY* array;
|
F_ARRAY* array = allot_object(type,sizeof(F_ARRAY) + capacity * CELLS);
|
||||||
array = allot_object(type,sizeof(F_ARRAY) + capacity * CELLS);
|
|
||||||
array->capacity = tag_fixnum(capacity);
|
array->capacity = tag_fixnum(capacity);
|
||||||
return array;
|
return array;
|
||||||
}
|
}
|
||||||
|
|
||||||
/* untagged */
|
|
||||||
F_ARRAY* array(CELL type, CELL capacity, CELL fill)
|
F_ARRAY* array(CELL type, CELL capacity, CELL fill)
|
||||||
{
|
{
|
||||||
int i;
|
int i; F_ARRAY* array = allot_array(type, capacity);
|
||||||
|
|
||||||
F_ARRAY* array = allot_array(type, capacity);
|
|
||||||
|
|
||||||
for(i = 0; i < capacity; i++)
|
for(i = 0; i < capacity; i++)
|
||||||
put(AREF(array,i),fill);
|
put(AREF(array,i),fill);
|
||||||
|
|
||||||
return array;
|
return array;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -43,27 +36,20 @@ void primitive_tuple(void)
|
||||||
F_ARRAY* grow_array(F_ARRAY* array, CELL capacity, CELL fill)
|
F_ARRAY* grow_array(F_ARRAY* array, CELL capacity, CELL fill)
|
||||||
{
|
{
|
||||||
/* later on, do an optimization: if end of array is here, just grow */
|
/* later on, do an optimization: if end of array is here, just grow */
|
||||||
int i;
|
int i; F_ARRAY* new_array;
|
||||||
F_ARRAY* new_array;
|
|
||||||
CELL curr_cap = array_capacity(array);
|
CELL curr_cap = array_capacity(array);
|
||||||
|
|
||||||
if(curr_cap >= capacity)
|
if(curr_cap >= capacity)
|
||||||
return array;
|
return array;
|
||||||
|
|
||||||
new_array = allot_array(untag_header(array->header),capacity);
|
new_array = allot_array(untag_header(array->header),capacity);
|
||||||
|
|
||||||
memcpy(new_array + 1,array + 1,curr_cap * CELLS);
|
memcpy(new_array + 1,array + 1,curr_cap * CELLS);
|
||||||
|
|
||||||
for(i = curr_cap; i < capacity; i++)
|
for(i = curr_cap; i < capacity; i++)
|
||||||
put(AREF(new_array,i),fill);
|
put(AREF(new_array,i),fill);
|
||||||
|
|
||||||
return new_array;
|
return new_array;
|
||||||
}
|
}
|
||||||
|
|
||||||
void primitive_grow_array(void)
|
void primitive_grow_array(void)
|
||||||
{
|
{
|
||||||
F_ARRAY* array;
|
F_ARRAY* array; CELL capacity;
|
||||||
CELL capacity;
|
|
||||||
maybe_garbage_collection();
|
maybe_garbage_collection();
|
||||||
array = untag_array(dpop());
|
array = untag_array(dpop());
|
||||||
capacity = to_fixnum(dpop());
|
capacity = to_fixnum(dpop());
|
||||||
|
@ -79,16 +65,14 @@ F_ARRAY* shrink_array(F_ARRAY* array, CELL capacity)
|
||||||
|
|
||||||
void fixup_array(F_ARRAY* array)
|
void fixup_array(F_ARRAY* array)
|
||||||
{
|
{
|
||||||
int i = 0;
|
int i = 0; CELL capacity = array_capacity(array);
|
||||||
CELL capacity = array_capacity(array);
|
|
||||||
for(i = 0; i < capacity; i++)
|
for(i = 0; i < capacity; i++)
|
||||||
data_fixup((void*)AREF(array,i));
|
data_fixup((void*)AREF(array,i));
|
||||||
}
|
}
|
||||||
|
|
||||||
void collect_array(F_ARRAY* array)
|
void collect_array(F_ARRAY* array)
|
||||||
{
|
{
|
||||||
int i = 0;
|
int i = 0; CELL capacity = array_capacity(array);
|
||||||
CELL capacity = array_capacity(array);
|
|
||||||
for(i = 0; i < capacity; i++)
|
for(i = 0; i < capacity; i++)
|
||||||
copy_handle((void*)AREF(array,i));
|
copy_handle((void*)AREF(array,i));
|
||||||
}
|
}
|
||||||
|
|
|
@ -80,19 +80,19 @@ void primitive_memory_to_string(void)
|
||||||
}
|
}
|
||||||
|
|
||||||
/* untagged */
|
/* untagged */
|
||||||
F_STRING* from_c_string(const BYTE* c_string)
|
F_STRING* from_c_string(const char* c_string)
|
||||||
{
|
{
|
||||||
return memory_to_string(c_string,strlen(c_string));
|
return memory_to_string((BYTE*)c_string,strlen(c_string));
|
||||||
}
|
}
|
||||||
|
|
||||||
/* FFI calls this */
|
/* FFI calls this */
|
||||||
void box_c_string(const BYTE* c_string)
|
void box_c_string(const char* c_string)
|
||||||
{
|
{
|
||||||
dpush(tag_object(from_c_string(c_string)));
|
dpush(tag_object(from_c_string(c_string)));
|
||||||
}
|
}
|
||||||
|
|
||||||
/* untagged */
|
/* untagged */
|
||||||
BYTE* to_c_string(F_STRING* s)
|
char* to_c_string(F_STRING* s)
|
||||||
{
|
{
|
||||||
CELL i;
|
CELL i;
|
||||||
CELL capacity = string_capacity(s);
|
CELL capacity = string_capacity(s);
|
||||||
|
@ -122,18 +122,18 @@ void primitive_string_to_memory(void)
|
||||||
}
|
}
|
||||||
|
|
||||||
/* untagged */
|
/* untagged */
|
||||||
BYTE* to_c_string_unchecked(F_STRING* s)
|
char* to_c_string_unchecked(F_STRING* s)
|
||||||
{
|
{
|
||||||
CELL capacity = string_capacity(s);
|
CELL capacity = string_capacity(s);
|
||||||
F_STRING* _c_str = allot_string(capacity / CHARS + 1);
|
F_STRING* _c_str = allot_string(capacity / CHARS + 1);
|
||||||
BYTE* c_str = (BYTE*)(_c_str + 1);
|
BYTE* c_str = (BYTE*)(_c_str + 1);
|
||||||
string_to_memory(s,c_str);
|
string_to_memory(s,c_str);
|
||||||
c_str[capacity] = '\0';
|
c_str[capacity] = '\0';
|
||||||
return c_str;
|
return (char*)c_str;
|
||||||
}
|
}
|
||||||
|
|
||||||
/* FFI calls this */
|
/* FFI calls this */
|
||||||
BYTE* unbox_c_string(void)
|
char* unbox_c_string(void)
|
||||||
{
|
{
|
||||||
return to_c_string(untag_string(dpop()));
|
return to_c_string(untag_string(dpop()));
|
||||||
}
|
}
|
||||||
|
|
|
@ -26,13 +26,13 @@ F_STRING* allot_string(CELL capacity);
|
||||||
F_STRING* string(CELL capacity, CELL fill);
|
F_STRING* string(CELL capacity, CELL fill);
|
||||||
void rehash_string(F_STRING* str);
|
void rehash_string(F_STRING* str);
|
||||||
F_STRING* grow_string(F_STRING* string, F_FIXNUM capacity, uint16_t fill);
|
F_STRING* grow_string(F_STRING* string, F_FIXNUM capacity, uint16_t fill);
|
||||||
BYTE* to_c_string(F_STRING* s);
|
char* to_c_string(F_STRING* s);
|
||||||
BYTE* to_c_string_unchecked(F_STRING* s);
|
char* to_c_string_unchecked(F_STRING* s);
|
||||||
void primitive_string_to_memory(void);
|
void primitive_string_to_memory(void);
|
||||||
DLLEXPORT void box_c_string(const BYTE* c_string);
|
DLLEXPORT void box_c_string(const char* c_string);
|
||||||
F_STRING* from_c_string(const BYTE* c_string);
|
F_STRING* from_c_string(const char* c_string);
|
||||||
void primitive_memory_to_string(void);
|
void primitive_memory_to_string(void);
|
||||||
DLLEXPORT BYTE* unbox_c_string(void);
|
DLLEXPORT char* unbox_c_string(void);
|
||||||
DLLEXPORT uint16_t* unbox_utf16_string(void);
|
DLLEXPORT uint16_t* unbox_utf16_string(void);
|
||||||
|
|
||||||
/* untagged & unchecked */
|
/* untagged & unchecked */
|
||||||
|
|
|
@ -83,7 +83,7 @@ bool perform_copy_from_io_task(F_PORT* port, F_PORT* other_port)
|
||||||
if(can_write(other_port,port->buf_fill))
|
if(can_write(other_port,port->buf_fill))
|
||||||
{
|
{
|
||||||
write_string_raw(other_port,
|
write_string_raw(other_port,
|
||||||
(BYTE*)(untag_string(port->buffer) + 1),
|
(char*)(untag_string(port->buffer) + 1),
|
||||||
port->buf_fill);
|
port->buf_fill);
|
||||||
port->buf_pos = port->buf_fill = 0;
|
port->buf_pos = port->buf_fill = 0;
|
||||||
}
|
}
|
||||||
|
|
|
@ -91,7 +91,7 @@ void write_char_8(F_PORT* port, F_FIXNUM ch)
|
||||||
}
|
}
|
||||||
|
|
||||||
/* Caller must ensure buffer is of the right size. */
|
/* Caller must ensure buffer is of the right size. */
|
||||||
void write_string_raw(F_PORT* port, BYTE* str, CELL len)
|
void write_string_raw(F_PORT* port, char* str, CELL len)
|
||||||
{
|
{
|
||||||
/* Append string to buffer */
|
/* Append string to buffer */
|
||||||
memcpy((void*)((CELL)untag_string(port->buffer) + sizeof(F_STRING)
|
memcpy((void*)((CELL)untag_string(port->buffer) + sizeof(F_STRING)
|
||||||
|
|
|
@ -4,6 +4,6 @@ void primitive_can_write(void);
|
||||||
void primitive_add_write_io_task(void);
|
void primitive_add_write_io_task(void);
|
||||||
bool perform_write_io_task(F_PORT* port);
|
bool perform_write_io_task(F_PORT* port);
|
||||||
void write_char_8(F_PORT* port, F_FIXNUM ch);
|
void write_char_8(F_PORT* port, F_FIXNUM ch);
|
||||||
void write_string_raw(F_PORT* port, BYTE* str, CELL len);
|
void write_string_raw(F_PORT* port, char* str, CELL len);
|
||||||
void write_string_8(F_PORT* port, F_STRING* str);
|
void write_string_8(F_PORT* port, F_STRING* str);
|
||||||
void primitive_write_8(void);
|
void primitive_write_8(void);
|
||||||
|
|
Loading…
Reference in New Issue