renaming rectangle tuple to rect and a few shape- words to rect-; working on spacial indexing
parent
9db68d9569
commit
2606de8e8e
|
@ -1,8 +1,11 @@
|
||||||
- reader syntax for arrays, byte arrays, displaced aliens
|
- reader syntax for arrays, byte arrays, displaced aliens
|
||||||
- fix infer hang
|
- fix infer hang
|
||||||
|
- out of memory error when printing global namespace
|
||||||
|
- HTML formatting
|
||||||
|
|
||||||
+ ui:
|
+ ui:
|
||||||
|
|
||||||
|
- adding/removing timers automatically for animated gadgets
|
||||||
- fix listener prompt display after presentation commands invoked
|
- fix listener prompt display after presentation commands invoked
|
||||||
- theme abstraction in ui
|
- theme abstraction in ui
|
||||||
- menu dragging
|
- menu dragging
|
||||||
|
@ -76,6 +79,8 @@
|
||||||
|
|
||||||
+ kernel:
|
+ kernel:
|
||||||
|
|
||||||
|
- merge timers with sleeping tasks
|
||||||
|
- what about tasks and timers between image restarts
|
||||||
- split: return vectors
|
- split: return vectors
|
||||||
- specialized arrays
|
- specialized arrays
|
||||||
- there is a problem with hashcodes of words and bootstrapping
|
- there is a problem with hashcodes of words and bootstrapping
|
||||||
|
|
|
@ -82,6 +82,13 @@ IN: sequences
|
||||||
swap dup empty?
|
swap dup empty?
|
||||||
[ 3drop -1 ] [ binsearch-slice (binsearch) ] ifte ;
|
[ 3drop -1 ] [ binsearch-slice (binsearch) ] ifte ;
|
||||||
inline
|
inline
|
||||||
|
|
||||||
|
: binsearch* ( elt seq quot -- elt | quot: elt elt -- -1/0/1 )
|
||||||
|
over >r binsearch dup -1 = [ r> 2drop f ] [ r> nth ] ifte ;
|
||||||
|
inline
|
||||||
|
|
||||||
: binsearch-range ( from to seq quot -- from to )
|
: binsearch-range ( from to seq quot -- from to )
|
||||||
[ binsearch ] 2keep rot >r binsearch r> ;
|
[ binsearch 0 max ] 2keep rot >r binsearch 1 + r> ; inline
|
||||||
|
|
||||||
|
: binsearch-slice ( from to seq quot -- slice )
|
||||||
|
over >r binsearch-range r> <slice> ; inline
|
||||||
|
|
|
@ -4,10 +4,6 @@ IN: prettyprint
|
||||||
USING: alien generic hashtables io kernel lists math namespaces
|
USING: alien generic hashtables io kernel lists math namespaces
|
||||||
parser sequences strings styles vectors words ;
|
parser sequences strings styles vectors words ;
|
||||||
|
|
||||||
! TODO:
|
|
||||||
! - out of memory when printing global namespace
|
|
||||||
! - formatting HTML code
|
|
||||||
|
|
||||||
! State
|
! State
|
||||||
SYMBOL: column
|
SYMBOL: column
|
||||||
SYMBOL: indent
|
SYMBOL: indent
|
||||||
|
@ -110,11 +106,8 @@ C: block ( -- block )
|
||||||
[ section-end fresh-line ] [ drop ] ifte ;
|
[ section-end fresh-line ] [ drop ] ifte ;
|
||||||
|
|
||||||
: advance ( section -- )
|
: advance ( section -- )
|
||||||
section-start last-newline get = [
|
section-start last-newline get =
|
||||||
last-newline inc
|
[ last-newline inc ] [ " " write ] ifte ;
|
||||||
] [
|
|
||||||
" " write
|
|
||||||
] ifte ;
|
|
||||||
|
|
||||||
: pprint-section ( section -- )
|
: pprint-section ( section -- )
|
||||||
last-newline? get [
|
last-newline? get [
|
||||||
|
@ -198,7 +191,7 @@ M: complex pprint* ( num -- )
|
||||||
\ }# pprint-word ;
|
\ }# pprint-word ;
|
||||||
|
|
||||||
: ch>ascii-escape ( ch -- esc )
|
: ch>ascii-escape ( ch -- esc )
|
||||||
[
|
{{
|
||||||
[[ CHAR: \e "\\e" ]]
|
[[ CHAR: \e "\\e" ]]
|
||||||
[[ CHAR: \n "\\n" ]]
|
[[ CHAR: \n "\\n" ]]
|
||||||
[[ CHAR: \r "\\r" ]]
|
[[ CHAR: \r "\\r" ]]
|
||||||
|
@ -206,7 +199,7 @@ M: complex pprint* ( num -- )
|
||||||
[[ CHAR: \0 "\\0" ]]
|
[[ CHAR: \0 "\\0" ]]
|
||||||
[[ CHAR: \\ "\\\\" ]]
|
[[ CHAR: \\ "\\\\" ]]
|
||||||
[[ CHAR: \" "\\\"" ]]
|
[[ CHAR: \" "\\\"" ]]
|
||||||
] assoc ;
|
}} hash ;
|
||||||
|
|
||||||
: ch>unicode-escape ( ch -- esc )
|
: ch>unicode-escape ( ch -- esc )
|
||||||
>hex 4 CHAR: 0 pad-left "\\u" swap append ;
|
>hex 4 CHAR: 0 pad-left "\\u" swap append ;
|
||||||
|
@ -290,7 +283,11 @@ M: tuple pprint* ( tuple -- )
|
||||||
[ <mirror> \ << \ >> pprint-sequence ] check-recursion ;
|
[ <mirror> \ << \ >> pprint-sequence ] check-recursion ;
|
||||||
|
|
||||||
M: alien pprint* ( alien -- )
|
M: alien pprint* ( alien -- )
|
||||||
\ ALIEN: pprint-word bl alien-address number>string f text ;
|
dup expired? [
|
||||||
|
drop "( alien expired )"
|
||||||
|
] [
|
||||||
|
\ ALIEN: pprint-word bl alien-address number>string
|
||||||
|
] ifte f text ;
|
||||||
|
|
||||||
M: wrapper pprint* ( wrapper -- )
|
M: wrapper pprint* ( wrapper -- )
|
||||||
dup wrapped word? [
|
dup wrapped word? [
|
||||||
|
|
|
@ -2,28 +2,28 @@ USING: gadgets kernel namespaces test ;
|
||||||
[ t ] [
|
[ t ] [
|
||||||
[
|
[
|
||||||
{ 2000 2000 0 } origin set
|
{ 2000 2000 0 } origin set
|
||||||
{ 2030 2040 0 } { 10 20 0 } { 300 400 0 } <rectangle> inside?
|
{ 2030 2040 0 } { 10 20 0 } { 300 400 0 } <rect> inside?
|
||||||
] with-scope
|
] with-scope
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ f ] [
|
[ f ] [
|
||||||
[
|
[
|
||||||
{ 2000 2000 0 } origin set
|
{ 2000 2000 0 } origin set
|
||||||
{ 2500 2040 0 } { 10 20 0 } { 300 400 0 } <rectangle> inside?
|
{ 2500 2040 0 } { 10 20 0 } { 300 400 0 } <rect> inside?
|
||||||
] with-scope
|
] with-scope
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ t ] [
|
[ t ] [
|
||||||
[
|
[
|
||||||
{ -10 -20 0 } origin set
|
{ -10 -20 0 } origin set
|
||||||
{ 0 0 0 } { 10 20 0 } { 300 400 0 } <rectangle> inside?
|
{ 0 0 0 } { 10 20 0 } { 300 400 0 } <rect> inside?
|
||||||
] with-scope
|
] with-scope
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ f ] [
|
[ f ] [
|
||||||
[
|
[
|
||||||
{ 0 0 0 } origin set
|
{ 0 0 0 } origin set
|
||||||
{ 10 10 0 } { 0 0 0 } { 10 10 0 } <rectangle> inside?
|
{ 10 10 0 } { 0 0 0 } { 10 10 0 } <rect> inside?
|
||||||
] with-scope
|
] with-scope
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
@ -40,3 +40,15 @@ USING: gadgets kernel namespaces test ;
|
||||||
<< rectangle f { 200 200 0 } { 40 40 0 } >>
|
<< rectangle f { 200 200 0 } { 40 40 0 } >>
|
||||||
intersect
|
intersect
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
[ f ] [
|
||||||
|
<< rectangle f { 100 100 0 } { 50 50 0 } >>
|
||||||
|
<< rectangle f { 200 200 0 } { 40 40 0 } >>
|
||||||
|
intersects?
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ t ] [
|
||||||
|
<< rectangle f { 100 100 0 } { 50 50 0 } >>
|
||||||
|
<< rectangle f { 120 120 0 } { 40 40 0 } >>
|
||||||
|
intersects?
|
||||||
|
] unit-test
|
||||||
|
|
|
@ -63,7 +63,7 @@ GENERIC: tick ( ms object -- )
|
||||||
: timers ( -- hash ) \ timers global hash ;
|
: timers ( -- hash ) \ timers global hash ;
|
||||||
|
|
||||||
: add-timer ( object delay -- )
|
: add-timer ( object delay -- )
|
||||||
[ <timer> ] keep timers set-hash ;
|
over >r <timer> r> timers set-hash ;
|
||||||
|
|
||||||
: remove-timer ( object -- ) timers remove-hash ;
|
: remove-timer ( object -- ) timers remove-hash ;
|
||||||
|
|
||||||
|
|
|
@ -14,9 +14,9 @@ M: book pref-dim ( book -- dim )
|
||||||
gadget-children { 0 0 0 } [ pref-dim vmax ] reduce ;
|
gadget-children { 0 0 0 } [ pref-dim vmax ] reduce ;
|
||||||
|
|
||||||
M: book layout* ( book -- )
|
M: book layout* ( book -- )
|
||||||
dup rectangle-dim over gadget-children [
|
dup rect-dim over gadget-children [
|
||||||
f over set-gadget-visible?
|
f over set-gadget-visible?
|
||||||
{ 0 0 0 } over set-rectangle-loc
|
{ 0 0 0 } over set-rect-loc
|
||||||
set-gadget-dim
|
set-gadget-dim
|
||||||
] each-with
|
] each-with
|
||||||
dup book-page swap gadget-children nth
|
dup book-page swap gadget-children nth
|
||||||
|
|
|
@ -21,10 +21,10 @@ C: border ( child delegate size -- border )
|
||||||
<bevel-gadget> { 5 5 0 } <border> ;
|
<bevel-gadget> { 5 5 0 } <border> ;
|
||||||
|
|
||||||
: layout-border-loc ( border -- )
|
: layout-border-loc ( border -- )
|
||||||
dup border-size swap gadget-child set-rectangle-loc ;
|
dup border-size swap gadget-child set-rect-loc ;
|
||||||
|
|
||||||
: layout-border-dim ( border -- )
|
: layout-border-dim ( border -- )
|
||||||
dup rectangle-dim over border-size 2 v*n v-
|
dup rect-dim over border-size 2 v*n v-
|
||||||
swap gadget-child set-gadget-dim ;
|
swap gadget-child set-gadget-dim ;
|
||||||
|
|
||||||
M: border pref-dim ( border -- dim )
|
M: border pref-dim ( border -- dim )
|
||||||
|
|
|
@ -17,10 +17,10 @@ C: caret ( -- caret )
|
||||||
|
|
||||||
M: caret tick* ( ms caret -- ) nip toggle-visible ;
|
M: caret tick* ( ms caret -- ) nip toggle-visible ;
|
||||||
|
|
||||||
: caret-block 500 ;
|
: caret-blink 500 ;
|
||||||
|
|
||||||
: add-caret ( caret parent -- )
|
: add-caret ( caret parent -- )
|
||||||
dupd add-gadget caret-block add-timer ;
|
dupd add-gadget caret-blink add-timer ;
|
||||||
|
|
||||||
: unparent-caret ( caret -- )
|
: unparent-caret ( caret -- )
|
||||||
dup remove-timer unparent ;
|
dup remove-timer unparent ;
|
||||||
|
@ -100,7 +100,7 @@ C: editor ( text -- )
|
||||||
0 0 3vector ;
|
0 0 3vector ;
|
||||||
|
|
||||||
: caret-dim ( editor -- w h )
|
: caret-dim ( editor -- w h )
|
||||||
rectangle-dim { 0 1 1 } v* { 1 0 0 } v+ ;
|
rect-dim { 0 1 1 } v* { 1 0 0 } v+ ;
|
||||||
|
|
||||||
M: editor user-input* ( ch editor -- ? )
|
M: editor user-input* ( ch editor -- ? )
|
||||||
[ insert-char ] with-editor t ;
|
[ insert-char ] with-editor t ;
|
||||||
|
@ -110,7 +110,7 @@ M: editor pref-dim ( editor -- dim )
|
||||||
|
|
||||||
M: editor layout* ( editor -- )
|
M: editor layout* ( editor -- )
|
||||||
dup editor-caret over caret-dim swap set-gadget-dim
|
dup editor-caret over caret-dim swap set-gadget-dim
|
||||||
dup editor-caret swap caret-loc swap set-rectangle-loc ;
|
dup editor-caret swap caret-loc swap set-rect-loc ;
|
||||||
|
|
||||||
M: editor draw-gadget* ( editor -- )
|
M: editor draw-gadget* ( editor -- )
|
||||||
dup delegate draw-gadget*
|
dup delegate draw-gadget*
|
||||||
|
|
|
@ -72,11 +72,11 @@ SYMBOL: frame-bottom-run
|
||||||
: var-frame-top \ frame-top var-frame-y ;
|
: var-frame-top \ frame-top var-frame-y ;
|
||||||
: var-frame-right
|
: var-frame-right
|
||||||
dup \ frame-right var-frame-x
|
dup \ frame-right var-frame-x
|
||||||
swap rectangle-dim first \ frame-right [ - ] change
|
swap rect-dim first \ frame-right [ - ] change
|
||||||
\ frame-right get \ frame-left get - frame-right-run set ;
|
\ frame-right get \ frame-left get - frame-right-run set ;
|
||||||
: var-frame-bottom
|
: var-frame-bottom
|
||||||
dup \ frame-bottom var-frame-y
|
dup \ frame-bottom var-frame-y
|
||||||
swap rectangle-dim second \ frame-bottom [ - ] change
|
swap rect-dim second \ frame-bottom [ - ] change
|
||||||
\ frame-bottom get \ frame-top get - frame-bottom-run set ;
|
\ frame-bottom get \ frame-top get - frame-bottom-run set ;
|
||||||
|
|
||||||
: setup-frame ( frame -- )
|
: setup-frame ( frame -- )
|
||||||
|
@ -86,7 +86,7 @@ SYMBOL: frame-bottom-run
|
||||||
var-frame-bottom ;
|
var-frame-bottom ;
|
||||||
|
|
||||||
: move-gadget ( x y gadget -- )
|
: move-gadget ( x y gadget -- )
|
||||||
>r 0 3vector r> set-rectangle-loc ;
|
>r 0 3vector r> set-rect-loc ;
|
||||||
|
|
||||||
: reshape-gadget ( x y w h gadget -- )
|
: reshape-gadget ( x y w h gadget -- )
|
||||||
[ >r 0 3vector r> set-gadget-dim ] keep move-gadget ;
|
[ >r 0 3vector r> set-gadget-dim ] keep move-gadget ;
|
||||||
|
|
|
@ -8,27 +8,33 @@ SYMBOL: origin
|
||||||
|
|
||||||
global [ { 0 0 0 } origin set ] bind
|
global [ { 0 0 0 } origin set ] bind
|
||||||
|
|
||||||
TUPLE: rectangle loc dim ;
|
TUPLE: rect loc dim ;
|
||||||
|
|
||||||
GENERIC: inside? ( loc shape -- ? )
|
GENERIC: inside? ( loc rect -- ? )
|
||||||
|
|
||||||
: shape-bounds ( shape -- loc dim )
|
: rect-bounds ( rect -- loc dim )
|
||||||
dup rectangle-loc swap rectangle-dim ;
|
dup rect-loc swap rect-dim ;
|
||||||
|
|
||||||
: shape-extent ( shape -- loc dim )
|
: rect-extent ( rect -- loc dim )
|
||||||
dup rectangle-loc dup rot rectangle-dim v+ ;
|
dup rect-loc dup rot rect-dim v+ ;
|
||||||
|
|
||||||
: screen-bounds ( shape -- rect )
|
: screen-loc ( rect -- loc )
|
||||||
shape-bounds >r origin get v+ r> <rectangle> ;
|
rect-loc origin get v+ ;
|
||||||
|
|
||||||
|
: screen-bounds ( rect -- rect )
|
||||||
|
dup screen-loc swap rect-dim <rect> ;
|
||||||
|
|
||||||
M: rectangle inside? ( loc rect -- ? )
|
M: rectangle inside? ( loc rect -- ? )
|
||||||
screen-bounds shape-bounds { 1 1 1 } v- { 0 0 0 } vmax
|
screen-bounds rect-bounds { 1 1 1 } v- { 0 0 0 } vmax
|
||||||
>r v- { 0 0 0 } r> vbetween? conjunction ;
|
>r v- { 0 0 0 } r> vbetween? conjunction ;
|
||||||
|
|
||||||
: intersect ( shape shape -- rect )
|
: intersect ( rect rect -- rect )
|
||||||
>r shape-extent r> shape-extent
|
>r rect-extent r> rect-extent swapd vmin >r vmax dup r>
|
||||||
swapd vmin >r vmax dup r> swap v- { 0 0 0 } vmax
|
swap v- { 0 0 0 } vmax <rect> ;
|
||||||
<rectangle> ;
|
|
||||||
|
: intersects? ( rect rect -- ? )
|
||||||
|
>r rect-extent r> rect-extent swapd vmin >r vmax r> v-
|
||||||
|
[ 0 < ] contains? ;
|
||||||
|
|
||||||
! A gadget is a rectangle, a paint, a mapping of gestures to
|
! A gadget is a rectangle, a paint, a mapping of gestures to
|
||||||
! actions, and a reference to the gadget's parent.
|
! actions, and a reference to the gadget's parent.
|
||||||
|
@ -39,7 +45,7 @@ TUPLE: gadget
|
||||||
: gadget-child gadget-children first ;
|
: gadget-child gadget-children first ;
|
||||||
|
|
||||||
C: gadget ( -- gadget )
|
C: gadget ( -- gadget )
|
||||||
{ 0 0 0 } dup <rectangle> over set-delegate
|
{ 0 0 0 } dup <rect> over set-delegate
|
||||||
t over set-gadget-visible? ;
|
t over set-gadget-visible? ;
|
||||||
|
|
||||||
DEFER: add-invalid
|
DEFER: add-invalid
|
||||||
|
@ -67,12 +73,12 @@ DEFER: add-invalid
|
||||||
dup add-invalid (relayout-down) ;
|
dup add-invalid (relayout-down) ;
|
||||||
|
|
||||||
: set-gadget-dim ( dim gadget -- )
|
: set-gadget-dim ( dim gadget -- )
|
||||||
2dup rectangle-dim =
|
2dup rect-dim =
|
||||||
[ 2drop ] [ [ set-rectangle-dim ] keep relayout-down ] ifte ;
|
[ 2drop ] [ [ set-rect-dim ] keep relayout-down ] ifte ;
|
||||||
|
|
||||||
GENERIC: pref-dim ( gadget -- dim )
|
GENERIC: pref-dim ( gadget -- dim )
|
||||||
|
|
||||||
M: gadget pref-dim rectangle-dim ;
|
M: gadget pref-dim rect-dim ;
|
||||||
|
|
||||||
GENERIC: layout* ( gadget -- )
|
GENERIC: layout* ( gadget -- )
|
||||||
|
|
||||||
|
@ -91,3 +97,25 @@ M: gadget focusable-child* drop t ;
|
||||||
: focusable-child ( gadget -- gadget )
|
: focusable-child ( gadget -- gadget )
|
||||||
dup focusable-child*
|
dup focusable-child*
|
||||||
dup t = [ drop ] [ nip focusable-child ] ifte ;
|
dup t = [ drop ] [ nip focusable-child ] ifte ;
|
||||||
|
|
||||||
|
GENERIC: pick-up* ( point gadget -- gadget )
|
||||||
|
|
||||||
|
: pick-up-list ( point gadgets -- gadget )
|
||||||
|
[
|
||||||
|
dup gadget-visible? [ inside? ] [ 2drop f ] ifte
|
||||||
|
] find-with nip ;
|
||||||
|
|
||||||
|
M: gadget pick-up* ( point gadget -- gadget )
|
||||||
|
gadget-children pick-up-list ;
|
||||||
|
|
||||||
|
: pick-up ( point gadget -- gadget )
|
||||||
|
#! The logic is thus. If the point is definately outside the
|
||||||
|
#! box, return f. Otherwise, see if the point is contained
|
||||||
|
#! in any subgadget. If not, see if it is contained in the
|
||||||
|
#! box delegate.
|
||||||
|
dup gadget-visible? >r 2dup inside? r> drop [
|
||||||
|
[ rect-loc v- ] keep 2dup
|
||||||
|
pick-up* [ pick-up ] [ nip ] ?ifte
|
||||||
|
] [
|
||||||
|
2drop f
|
||||||
|
] ifte ;
|
||||||
|
|
|
@ -4,23 +4,6 @@ IN: gadgets
|
||||||
USING: alien generic io kernel lists math matrices namespaces
|
USING: alien generic io kernel lists math matrices namespaces
|
||||||
prettyprint sdl sequences vectors ;
|
prettyprint sdl sequences vectors ;
|
||||||
|
|
||||||
: (pick-up) ( point gadget -- gadget )
|
|
||||||
gadget-children reverse-slice [
|
|
||||||
dup gadget-visible? [ inside? ] [ 2drop f ] ifte
|
|
||||||
] find-with nip ;
|
|
||||||
|
|
||||||
: pick-up ( point gadget -- gadget )
|
|
||||||
#! The logic is thus. If the point is definately outside the
|
|
||||||
#! box, return f. Otherwise, see if the point is contained
|
|
||||||
#! in any subgadget. If not, see if it is contained in the
|
|
||||||
#! box delegate.
|
|
||||||
dup gadget-visible? >r 2dup inside? r> drop [
|
|
||||||
[ rectangle-loc v- ] keep 2dup
|
|
||||||
(pick-up) [ pick-up ] [ nip ] ?ifte
|
|
||||||
] [
|
|
||||||
2drop f
|
|
||||||
] ifte ;
|
|
||||||
|
|
||||||
! The hand is a special gadget that holds mouse position and
|
! The hand is a special gadget that holds mouse position and
|
||||||
! mouse button click state. The hand's parent is the world, but
|
! mouse button click state. The hand's parent is the world, but
|
||||||
! it is special in that the world does not list it as part of
|
! it is special in that the world does not list it as part of
|
||||||
|
@ -72,13 +55,13 @@ C: hand ( world -- hand )
|
||||||
|
|
||||||
: move-hand ( loc hand -- )
|
: move-hand ( loc hand -- )
|
||||||
dup hand-gadget parents-down >r
|
dup hand-gadget parents-down >r
|
||||||
2dup set-rectangle-loc
|
2dup set-rect-loc
|
||||||
[ >r world get pick-up r> set-hand-gadget ] keep
|
[ >r world get pick-up r> set-hand-gadget ] keep
|
||||||
dup hand-gadget parents-down r> hand-gestures ;
|
dup hand-gadget parents-down r> hand-gestures ;
|
||||||
|
|
||||||
: update-hand ( hand -- )
|
: update-hand ( hand -- )
|
||||||
#! Called when a gadget is removed or added.
|
#! Called when a gadget is removed or added.
|
||||||
dup rectangle-loc swap move-hand ;
|
dup rect-loc swap move-hand ;
|
||||||
|
|
||||||
: focus-gestures ( new old -- )
|
: focus-gestures ( new old -- )
|
||||||
drop-prefix
|
drop-prefix
|
||||||
|
|
|
@ -55,7 +55,7 @@ sequences vectors ;
|
||||||
|
|
||||||
: screen-loc ( gadget -- point )
|
: screen-loc ( gadget -- point )
|
||||||
#! The position of the gadget on the screen.
|
#! The position of the gadget on the screen.
|
||||||
parents-up { 0 0 0 } [ rectangle-loc v+ ] reduce ;
|
parents-up { 0 0 0 } [ rect-loc v+ ] reduce ;
|
||||||
|
|
||||||
: relative ( g1 g2 -- g2-g1 )
|
: relative ( g1 g2 -- g2-g1 )
|
||||||
screen-loc swap screen-loc v- ;
|
screen-loc swap screen-loc v- ;
|
||||||
|
|
|
@ -24,7 +24,7 @@ M: incremental layout* drop ;
|
||||||
|
|
||||||
: next-cursor ( gadget incremental -- cursor )
|
: next-cursor ( gadget incremental -- cursor )
|
||||||
[
|
[
|
||||||
swap rectangle-dim swap incremental-cursor
|
swap rect-dim swap incremental-cursor
|
||||||
2dup v+ >r vmax r>
|
2dup v+ >r vmax r>
|
||||||
] keep pack-vector set-axis ;
|
] keep pack-vector set-axis ;
|
||||||
|
|
||||||
|
@ -33,10 +33,10 @@ M: incremental layout* drop ;
|
||||||
|
|
||||||
: incremental-loc ( gadget incremental -- )
|
: incremental-loc ( gadget incremental -- )
|
||||||
dup incremental-cursor swap pack-vector v*
|
dup incremental-cursor swap pack-vector v*
|
||||||
swap set-rectangle-loc ;
|
swap set-rect-loc ;
|
||||||
|
|
||||||
: prefer-incremental ( gadget -- )
|
: prefer-incremental ( gadget -- )
|
||||||
dup pref-dim over set-rectangle-dim layout ;
|
dup pref-dim over set-rect-dim layout ;
|
||||||
|
|
||||||
: add-incremental ( gadget incremental -- )
|
: add-incremental ( gadget incremental -- )
|
||||||
2dup (add-gadget)
|
2dup (add-gadget)
|
||||||
|
|
|
@ -27,7 +27,7 @@ TUPLE: pack align fill vector ;
|
||||||
|
|
||||||
: packed-dim-2 ( gadget sizes -- list )
|
: packed-dim-2 ( gadget sizes -- list )
|
||||||
[
|
[
|
||||||
over rectangle-dim { 1 1 1 } vmax over v-
|
over rect-dim { 1 1 1 } vmax over v-
|
||||||
rot pack-fill v*n v+
|
rot pack-fill v*n v+
|
||||||
] map-with ;
|
] map-with ;
|
||||||
|
|
||||||
|
@ -42,9 +42,9 @@ TUPLE: pack align fill vector ;
|
||||||
{ 0 0 0 } [ v+ ] accumulate ;
|
{ 0 0 0 } [ v+ ] accumulate ;
|
||||||
|
|
||||||
: packed-loc-2 ( gadget sizes -- seq )
|
: packed-loc-2 ( gadget sizes -- seq )
|
||||||
>r dup rectangle-dim { 1 1 1 } vmax over r>
|
>r dup rect-dim { 1 1 1 } vmax over r>
|
||||||
packed-dim-2 [ v- ] map-with
|
packed-dim-2 [ v- ] map-with
|
||||||
>r dup pack-align swap rectangle-dim { 1 1 1 } vmax r>
|
>r dup pack-align swap rect-dim { 1 1 1 } vmax r>
|
||||||
[ >r 2dup r> v- n*v ] map 2nip ;
|
[ >r 2dup r> v- n*v ] map 2nip ;
|
||||||
|
|
||||||
: (packed-locs) ( gadget sizes -- seq )
|
: (packed-locs) ( gadget sizes -- seq )
|
||||||
|
@ -52,7 +52,7 @@ TUPLE: pack align fill vector ;
|
||||||
|
|
||||||
: packed-locs ( gadget sizes -- )
|
: packed-locs ( gadget sizes -- )
|
||||||
over gadget-children >r (packed-locs) r>
|
over gadget-children >r (packed-locs) r>
|
||||||
[ set-rectangle-loc ] 2each ;
|
[ set-rect-loc ] 2each ;
|
||||||
|
|
||||||
: packed-layout ( gadget sizes -- )
|
: packed-layout ( gadget sizes -- )
|
||||||
2dup packed-locs packed-dims ;
|
2dup packed-locs packed-dims ;
|
||||||
|
@ -83,6 +83,24 @@ M: pack pref-dim ( pack -- dim )
|
||||||
|
|
||||||
M: pack layout* ( pack -- ) dup pref-dims packed-layout ;
|
M: pack layout* ( pack -- ) dup pref-dims packed-layout ;
|
||||||
|
|
||||||
: <stack> ( list -- gadget )
|
: pick-up-fast ( axis point gadgets -- gadget )
|
||||||
|
[ rect-loc v- over v. ] binsearch* nip ;
|
||||||
|
|
||||||
|
M: pack pick-up* ( point pack -- gadget )
|
||||||
|
dup pack-vector pick rot gadget-children
|
||||||
|
pick-up-fast tuck inside? [ drop f ] unless ;
|
||||||
|
|
||||||
|
! M: pack visible-children* ( rect gadget -- list )
|
||||||
|
! gadget-children [ rect-loc origin get v+ intersects? ] subset-with ;
|
||||||
|
|
||||||
|
TUPLE: stack ;
|
||||||
|
|
||||||
|
C: stack ( -- gadget )
|
||||||
#! A stack lays out all its children on top of each other.
|
#! A stack lays out all its children on top of each other.
|
||||||
0 1 { 0 0 1 } <pack> swap [ over add-gadget ] each ;
|
0 1 { 0 0 1 } <pack> over set-delegate ;
|
||||||
|
|
||||||
|
M: stack pick-up* ( point stack -- gadget )
|
||||||
|
gadget-children reverse-slice pick-up-list ;
|
||||||
|
|
||||||
|
M: stack visible-children* ( rect gadget -- list )
|
||||||
|
nip gadget-children ;
|
||||||
|
|
|
@ -10,7 +10,6 @@ USING: kernel parser sequences io ;
|
||||||
"/library/ui/borders.factor"
|
"/library/ui/borders.factor"
|
||||||
"/library/ui/frames.factor"
|
"/library/ui/frames.factor"
|
||||||
"/library/ui/world.factor"
|
"/library/ui/world.factor"
|
||||||
"/library/ui/timer.factor"
|
|
||||||
"/library/ui/hand.factor"
|
"/library/ui/hand.factor"
|
||||||
"/library/ui/labels.factor"
|
"/library/ui/labels.factor"
|
||||||
"/library/ui/buttons.factor"
|
"/library/ui/buttons.factor"
|
||||||
|
|
|
@ -4,7 +4,7 @@ IN: gadgets
|
||||||
USING: generic kernel lists math namespaces sequences ;
|
USING: generic kernel lists math namespaces sequences ;
|
||||||
|
|
||||||
: show-menu ( menu -- )
|
: show-menu ( menu -- )
|
||||||
hand screen-loc over set-rectangle-loc show-glass ;
|
hand screen-loc over set-rect-loc show-glass ;
|
||||||
|
|
||||||
: menu-item-border ( child -- border )
|
: menu-item-border ( child -- border )
|
||||||
<plain-gadget> { 1 1 0 } <border> ;
|
<plain-gadget> { 1 1 0 } <border> ;
|
||||||
|
|
|
@ -7,32 +7,35 @@ namespaces sdl sequences strings styles vectors ;
|
||||||
SYMBOL: clip
|
SYMBOL: clip
|
||||||
|
|
||||||
: >sdl-rect ( rectangle -- sdlrect )
|
: >sdl-rect ( rectangle -- sdlrect )
|
||||||
[ rectangle-loc 2unseq ] keep rectangle-dim 2unseq make-rect ;
|
[ rect-loc 2unseq ] keep rect-dim 2unseq make-rect ;
|
||||||
|
|
||||||
: set-clip ( rect -- ? )
|
: set-clip ( rect -- )
|
||||||
#! The top/left corner of the clip rectangle is the location
|
#! The top/left corner of the clip rectangle is the location
|
||||||
#! of the gadget on the screen. The bottom/right is the
|
#! of the gadget on the screen. The bottom/right is the
|
||||||
#! intersected clip rectangle. Return f if the clip region
|
#! intersected clip rectangle.
|
||||||
#! is an empty region.
|
surface get swap >sdl-rect SDL_SetClipRect drop ;
|
||||||
surface get swap >sdl-rect SDL_SetClipRect ;
|
|
||||||
|
|
||||||
: with-clip ( shape quot -- )
|
GENERIC: visible-children* ( rect gadget -- list )
|
||||||
#! All drawing done inside the quotation is clipped to the
|
|
||||||
#! shape's bounds.
|
M: gadget visible-children* ( rect gadget -- list )
|
||||||
[
|
gadget-children [ screen-bounds intersects? ] subset-with ;
|
||||||
>r screen-bounds clip [ intersect dup ] change set-clip
|
|
||||||
[ r> call ] [ r> 2drop ] ifte
|
: visible-children ( gadget -- list )
|
||||||
] with-scope ; inline
|
clip get swap visible-children* ;
|
||||||
|
|
||||||
GENERIC: draw-gadget* ( gadget -- )
|
GENERIC: draw-gadget* ( gadget -- )
|
||||||
|
|
||||||
|
: translate&clip ( gadget -- )
|
||||||
|
screen-bounds dup rect-loc origin set
|
||||||
|
clip [ intersect dup ] change ( set-clip ) drop ;
|
||||||
|
|
||||||
: draw-gadget ( gadget -- )
|
: draw-gadget ( gadget -- )
|
||||||
dup gadget-visible? [
|
dup gadget-visible? [
|
||||||
dup [
|
dup [
|
||||||
dup rectangle-loc origin [ v+ ] change
|
translate&clip
|
||||||
dup draw-gadget*
|
dup draw-gadget*
|
||||||
gadget-children [ draw-gadget ] each
|
visible-children [ draw-gadget ] each
|
||||||
] with-clip
|
] with-scope
|
||||||
] [ drop ] ifte ;
|
] [ drop ] ifte ;
|
||||||
|
|
||||||
: paint-prop* ( gadget key -- value )
|
: paint-prop* ( gadget key -- value )
|
||||||
|
@ -73,14 +76,15 @@ M: f draw-boundary 2drop ;
|
||||||
TUPLE: solid ;
|
TUPLE: solid ;
|
||||||
|
|
||||||
: rect>screen ( shape -- x1 y1 x2 y2 )
|
: rect>screen ( shape -- x1 y1 x2 y2 )
|
||||||
>r origin get dup r> rectangle-dim v+ >r 2unseq r> 2unseq ;
|
>r origin get dup r> rect-dim v+
|
||||||
|
>r 2unseq r> 2unseq >r 1 - r> 1 - ;
|
||||||
|
|
||||||
! Solid pen
|
! Solid pen
|
||||||
M: solid draw-interior
|
M: solid draw-interior
|
||||||
drop >r surface get r> [ rect>screen ] keep bg rgb boxColor ;
|
drop >r surface get r> [ rect>screen ] keep bg rgb boxColor ;
|
||||||
|
|
||||||
M: solid draw-boundary
|
M: solid draw-boundary
|
||||||
drop >r surface get r> [ rect>screen >r 1 - r> 1 - ] keep
|
drop >r surface get r> [ rect>screen ] keep
|
||||||
fg rgb rectangleColor ;
|
fg rgb rectangleColor ;
|
||||||
|
|
||||||
! Gradient pen
|
! Gradient pen
|
||||||
|
@ -113,7 +117,7 @@ TUPLE: gradient vector from to ;
|
||||||
dup first [ 3dup gradient-y ] repeat 2drop ;
|
dup first [ 3dup gradient-y ] repeat 2drop ;
|
||||||
|
|
||||||
M: gradient draw-interior ( gadget gradient -- )
|
M: gradient draw-interior ( gadget gradient -- )
|
||||||
swap rectangle-dim { 1 1 1 } vmax
|
swap rect-dim { 1 1 1 } vmax
|
||||||
over gradient-vector { 1 0 0 } =
|
over gradient-vector { 1 0 0 } =
|
||||||
[ horiz-gradient ] [ vert-gradient ] ifte ;
|
[ horiz-gradient ] [ vert-gradient ] ifte ;
|
||||||
|
|
||||||
|
@ -144,7 +148,7 @@ SYMBOL: bevel-2
|
||||||
M: bevel draw-boundary ( gadget boundary -- )
|
M: bevel draw-boundary ( gadget boundary -- )
|
||||||
#! Ugly code.
|
#! Ugly code.
|
||||||
bevel-width [
|
bevel-width [
|
||||||
>r origin get over rectangle-dim over v+ r>
|
>r origin get over rect-dim over v+ r>
|
||||||
{ 1 1 0 } n*v tuck v- { 1 1 0 } v- >r v+ r>
|
{ 1 1 0 } n*v tuck v- { 1 1 0 } v- >r v+ r>
|
||||||
rot draw-bevel
|
rot draw-bevel
|
||||||
] each-with ;
|
] each-with ;
|
||||||
|
|
|
@ -16,7 +16,7 @@ TUPLE: scroller viewport x y ;
|
||||||
: viewport-dim gadget-child pref-dim ;
|
: viewport-dim gadget-child pref-dim ;
|
||||||
|
|
||||||
: fix-scroll ( origin viewport -- origin )
|
: fix-scroll ( origin viewport -- origin )
|
||||||
dup rectangle-dim swap viewport-dim v- vmax { 0 0 0 } vmin ;
|
dup rect-dim swap viewport-dim v- vmax { 0 0 0 } vmin ;
|
||||||
|
|
||||||
: scroll-viewport ( origin viewport -- )
|
: scroll-viewport ( origin viewport -- )
|
||||||
[ fix-scroll ] keep [ set-viewport-origin ] keep relayout ;
|
[ fix-scroll ] keep [ set-viewport-origin ] keep relayout ;
|
||||||
|
@ -41,13 +41,13 @@ M: viewport pref-dim gadget-child pref-dim ;
|
||||||
M: viewport layout* ( viewport -- )
|
M: viewport layout* ( viewport -- )
|
||||||
dup gadget-child dup prefer
|
dup gadget-child dup prefer
|
||||||
>r dup viewport-origin* swap fix-scroll r>
|
>r dup viewport-origin* swap fix-scroll r>
|
||||||
set-rectangle-loc ;
|
set-rect-loc ;
|
||||||
|
|
||||||
M: viewport focusable-child* ( viewport -- gadget )
|
M: viewport focusable-child* ( viewport -- gadget )
|
||||||
gadget-child ;
|
gadget-child ;
|
||||||
|
|
||||||
: visible-portion ( viewport -- vector )
|
: visible-portion ( viewport -- vector )
|
||||||
dup rectangle-dim { 1 1 1 } vmax
|
dup rect-dim { 1 1 1 } vmax
|
||||||
swap viewport-dim { 1 1 1 } vmax
|
swap viewport-dim { 1 1 1 } vmax
|
||||||
v/ { 1 1 1 } vmin ;
|
v/ { 1 1 1 } vmin ;
|
||||||
|
|
||||||
|
@ -117,13 +117,13 @@ C: slider ( vector -- slider )
|
||||||
: slider-dim { 12 12 12 } ;
|
: slider-dim { 12 12 12 } ;
|
||||||
|
|
||||||
: thumb-dim ( slider -- h )
|
: thumb-dim ( slider -- h )
|
||||||
[ rectangle-dim dup ] keep >thumb slider-dim vmax vmin ;
|
[ rect-dim dup ] keep >thumb slider-dim vmax vmin ;
|
||||||
|
|
||||||
M: slider pref-dim drop slider-dim ;
|
M: slider pref-dim drop slider-dim ;
|
||||||
|
|
||||||
M: slider layout* ( slider -- )
|
M: slider layout* ( slider -- )
|
||||||
dup thumb-loc over slider-vector v*
|
dup thumb-loc over slider-vector v*
|
||||||
over slider-thumb set-rectangle-loc
|
over slider-thumb set-rect-loc
|
||||||
dup thumb-dim over slider-vector v* slider-dim vmax
|
dup thumb-dim over slider-vector v* slider-dim vmax
|
||||||
swap slider-thumb set-gadget-dim ;
|
swap slider-thumb set-gadget-dim ;
|
||||||
|
|
||||||
|
|
|
@ -17,7 +17,7 @@ TUPLE: splitter split ;
|
||||||
|
|
||||||
: divider-motion ( splitter -- )
|
: divider-motion ( splitter -- )
|
||||||
dup hand>split
|
dup hand>split
|
||||||
over rectangle-dim { 1 1 1 } vmax v/ over pack-vector v.
|
over rect-dim { 1 1 1 } vmax v/ over pack-vector v.
|
||||||
0 max 1 min over set-splitter-split relayout ;
|
0 max 1 min over set-splitter-split relayout ;
|
||||||
|
|
||||||
: divider-actions ( thumb -- )
|
: divider-actions ( thumb -- )
|
||||||
|
@ -45,14 +45,14 @@ C: splitter ( first second split vector -- splitter )
|
||||||
{ 1 0 0 } <splitter> ;
|
{ 1 0 0 } <splitter> ;
|
||||||
|
|
||||||
: splitter-part ( splitter -- vec )
|
: splitter-part ( splitter -- vec )
|
||||||
dup splitter-split swap rectangle-dim
|
dup splitter-split swap rect-dim
|
||||||
n*v divider-size 1/2 v*n v- ;
|
n*v divider-size 1/2 v*n v- ;
|
||||||
|
|
||||||
: splitter-layout ( splitter -- { a b c } )
|
: splitter-layout ( splitter -- { a b c } )
|
||||||
[
|
[
|
||||||
dup splitter-part ,
|
dup splitter-part ,
|
||||||
divider-size ,
|
divider-size ,
|
||||||
dup rectangle-dim divider-size v- swap splitter-part v- ,
|
dup rect-dim divider-size v- swap splitter-part v- ,
|
||||||
] make-vector ;
|
] make-vector ;
|
||||||
|
|
||||||
M: splitter layout* ( splitter -- )
|
M: splitter layout* ( splitter -- )
|
||||||
|
|
|
@ -61,7 +61,7 @@ IN: shells
|
||||||
#! dimensions.
|
#! dimensions.
|
||||||
ttf-init
|
ttf-init
|
||||||
?init-world
|
?init-world
|
||||||
world get rectangle-dim 2unseq 0 SDL_RESIZABLE [
|
world get rect-dim 2unseq 0 SDL_RESIZABLE [
|
||||||
[
|
[
|
||||||
"Factor " version append dup SDL_WM_SetCaption
|
"Factor " version append dup SDL_WM_SetCaption
|
||||||
start-world
|
start-world
|
||||||
|
|
|
@ -16,7 +16,7 @@ DEFER: update-hand
|
||||||
DEFER: do-timers
|
DEFER: do-timers
|
||||||
|
|
||||||
C: world ( -- world )
|
C: world ( -- world )
|
||||||
f <stack> over set-delegate
|
<stack> over set-delegate
|
||||||
t over set-gadget-root?
|
t over set-gadget-root?
|
||||||
dup <hand> over set-world-hand ;
|
dup <hand> over set-world-hand ;
|
||||||
|
|
||||||
|
@ -47,7 +47,7 @@ M: world inside? ( point world -- ? ) 2drop t ;
|
||||||
|
|
||||||
: draw-world ( world -- )
|
: draw-world ( world -- )
|
||||||
[
|
[
|
||||||
{ 0 0 0 } width get height get 0 3vector <rectangle> clip set
|
{ 0 0 0 } width get height get 0 3vector <rect> clip set
|
||||||
draw-gadget
|
draw-gadget
|
||||||
] with-surface ;
|
] with-surface ;
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue