renaming rectangle tuple to rect and a few shape- words to rect-; working on spacial indexing
Slava Pestov
parent
9db68d9569
commit
2606de8e8e
|
|
@ -1,8 +1,11 @@
|
|||
- reader syntax for arrays, byte arrays, displaced aliens
|
||||
- fix infer hang
|
||||
- out of memory error when printing global namespace
|
||||
- HTML formatting
|
||||
|
||||
+ ui:
|
||||
|
||||
- adding/removing timers automatically for animated gadgets
|
||||
- fix listener prompt display after presentation commands invoked
|
||||
- theme abstraction in ui
|
||||
- menu dragging
|
||||
|
|
@ -76,6 +79,8 @@
|
|||
|
||||
+ kernel:
|
||||
|
||||
- merge timers with sleeping tasks
|
||||
- what about tasks and timers between image restarts
|
||||
- split: return vectors
|
||||
- specialized arrays
|
||||
- there is a problem with hashcodes of words and bootstrapping
|
||||
|
|
|
|||
|
|
@ -82,6 +82,13 @@ IN: sequences
|
|||
swap dup empty?
|
||||
[ 3drop -1 ] [ binsearch-slice (binsearch) ] ifte ;
|
||||
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 ] 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
|
||||
parser sequences strings styles vectors words ;
|
||||
|
||||
! TODO:
|
||||
! - out of memory when printing global namespace
|
||||
! - formatting HTML code
|
||||
|
||||
! State
|
||||
SYMBOL: column
|
||||
SYMBOL: indent
|
||||
|
|
@ -110,11 +106,8 @@ C: block ( -- block )
|
|||
[ section-end fresh-line ] [ drop ] ifte ;
|
||||
|
||||
: advance ( section -- )
|
||||
section-start last-newline get = [
|
||||
last-newline inc
|
||||
] [
|
||||
" " write
|
||||
] ifte ;
|
||||
section-start last-newline get =
|
||||
[ last-newline inc ] [ " " write ] ifte ;
|
||||
|
||||
: pprint-section ( section -- )
|
||||
last-newline? get [
|
||||
|
|
@ -198,7 +191,7 @@ M: complex pprint* ( num -- )
|
|||
\ }# pprint-word ;
|
||||
|
||||
: ch>ascii-escape ( ch -- esc )
|
||||
[
|
||||
{{
|
||||
[[ CHAR: \e "\\e" ]]
|
||||
[[ CHAR: \n "\\n" ]]
|
||||
[[ CHAR: \r "\\r" ]]
|
||||
|
|
@ -206,7 +199,7 @@ M: complex pprint* ( num -- )
|
|||
[[ CHAR: \0 "\\0" ]]
|
||||
[[ CHAR: \\ "\\\\" ]]
|
||||
[[ CHAR: \" "\\\"" ]]
|
||||
] assoc ;
|
||||
}} hash ;
|
||||
|
||||
: ch>unicode-escape ( ch -- esc )
|
||||
>hex 4 CHAR: 0 pad-left "\\u" swap append ;
|
||||
|
|
@ -290,7 +283,11 @@ M: tuple pprint* ( tuple -- )
|
|||
[ <mirror> \ << \ >> pprint-sequence ] check-recursion ;
|
||||
|
||||
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 -- )
|
||||
dup wrapped word? [
|
||||
|
|
|
|||
|
|
@ -2,28 +2,28 @@ USING: gadgets kernel namespaces test ;
|
|||
[ t ] [
|
||||
[
|
||||
{ 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
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[
|
||||
{ 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
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[
|
||||
{ -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
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[
|
||||
{ 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
|
||||
] unit-test
|
||||
|
||||
|
|
@ -40,3 +40,15 @@ USING: gadgets kernel namespaces test ;
|
|||
<< rectangle f { 200 200 0 } { 40 40 0 } >>
|
||||
intersect
|
||||
] 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 ;
|
||||
|
||||
: add-timer ( object delay -- )
|
||||
[ <timer> ] keep timers set-hash ;
|
||||
over >r <timer> r> timers set-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 ;
|
||||
|
||||
M: book layout* ( book -- )
|
||||
dup rectangle-dim over gadget-children [
|
||||
dup rect-dim over gadget-children [
|
||||
f over set-gadget-visible?
|
||||
{ 0 0 0 } over set-rectangle-loc
|
||||
{ 0 0 0 } over set-rect-loc
|
||||
set-gadget-dim
|
||||
] each-with
|
||||
dup book-page swap gadget-children nth
|
||||
|
|
|
|||
|
|
@ -21,10 +21,10 @@ C: border ( child delegate size -- border )
|
|||
<bevel-gadget> { 5 5 0 } <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 -- )
|
||||
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 ;
|
||||
|
||||
M: border pref-dim ( border -- dim )
|
||||
|
|
|
|||
|
|
@ -17,10 +17,10 @@ C: caret ( -- caret )
|
|||
|
||||
M: caret tick* ( ms caret -- ) nip toggle-visible ;
|
||||
|
||||
: caret-block 500 ;
|
||||
: caret-blink 500 ;
|
||||
|
||||
: add-caret ( caret parent -- )
|
||||
dupd add-gadget caret-block add-timer ;
|
||||
dupd add-gadget caret-blink add-timer ;
|
||||
|
||||
: unparent-caret ( caret -- )
|
||||
dup remove-timer unparent ;
|
||||
|
|
@ -100,7 +100,7 @@ C: editor ( text -- )
|
|||
0 0 3vector ;
|
||||
|
||||
: 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 -- ? )
|
||||
[ insert-char ] with-editor t ;
|
||||
|
|
@ -110,7 +110,7 @@ M: editor pref-dim ( editor -- dim )
|
|||
|
||||
M: editor layout* ( editor -- )
|
||||
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 -- )
|
||||
dup delegate draw-gadget*
|
||||
|
|
|
|||
|
|
@ -72,11 +72,11 @@ SYMBOL: frame-bottom-run
|
|||
: var-frame-top \ frame-top var-frame-y ;
|
||||
: var-frame-right
|
||||
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 ;
|
||||
: var-frame-bottom
|
||||
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 ;
|
||||
|
||||
: setup-frame ( frame -- )
|
||||
|
|
@ -86,7 +86,7 @@ SYMBOL: frame-bottom-run
|
|||
var-frame-bottom ;
|
||||
|
||||
: 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 -- )
|
||||
[ >r 0 3vector r> set-gadget-dim ] keep move-gadget ;
|
||||
|
|
|
|||
|
|
@ -8,27 +8,33 @@ SYMBOL: origin
|
|||
|
||||
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 )
|
||||
dup rectangle-loc swap rectangle-dim ;
|
||||
: rect-bounds ( rect -- loc dim )
|
||||
dup rect-loc swap rect-dim ;
|
||||
|
||||
: shape-extent ( shape -- loc dim )
|
||||
dup rectangle-loc dup rot rectangle-dim v+ ;
|
||||
: rect-extent ( rect -- loc dim )
|
||||
dup rect-loc dup rot rect-dim v+ ;
|
||||
|
||||
: screen-bounds ( shape -- rect )
|
||||
shape-bounds >r origin get v+ r> <rectangle> ;
|
||||
: screen-loc ( rect -- loc )
|
||||
rect-loc origin get v+ ;
|
||||
|
||||
: screen-bounds ( rect -- rect )
|
||||
dup screen-loc swap rect-dim <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 ;
|
||||
|
||||
: intersect ( shape shape -- rect )
|
||||
>r shape-extent r> shape-extent
|
||||
swapd vmin >r vmax dup r> swap v- { 0 0 0 } vmax
|
||||
<rectangle> ;
|
||||
: intersect ( rect rect -- rect )
|
||||
>r rect-extent r> rect-extent swapd vmin >r vmax dup r>
|
||||
swap v- { 0 0 0 } vmax <rect> ;
|
||||
|
||||
: 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
|
||||
! actions, and a reference to the gadget's parent.
|
||||
|
|
@ -39,7 +45,7 @@ TUPLE: gadget
|
|||
: gadget-child gadget-children first ;
|
||||
|
||||
C: gadget ( -- gadget )
|
||||
{ 0 0 0 } dup <rectangle> over set-delegate
|
||||
{ 0 0 0 } dup <rect> over set-delegate
|
||||
t over set-gadget-visible? ;
|
||||
|
||||
DEFER: add-invalid
|
||||
|
|
@ -67,12 +73,12 @@ DEFER: add-invalid
|
|||
dup add-invalid (relayout-down) ;
|
||||
|
||||
: set-gadget-dim ( dim gadget -- )
|
||||
2dup rectangle-dim =
|
||||
[ 2drop ] [ [ set-rectangle-dim ] keep relayout-down ] ifte ;
|
||||
2dup rect-dim =
|
||||
[ 2drop ] [ [ set-rect-dim ] keep relayout-down ] ifte ;
|
||||
|
||||
GENERIC: pref-dim ( gadget -- dim )
|
||||
|
||||
M: gadget pref-dim rectangle-dim ;
|
||||
M: gadget pref-dim rect-dim ;
|
||||
|
||||
GENERIC: layout* ( gadget -- )
|
||||
|
||||
|
|
@ -91,3 +97,25 @@ M: gadget focusable-child* drop t ;
|
|||
: focusable-child ( gadget -- gadget )
|
||||
dup focusable-child*
|
||||
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
|
||||
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
|
||||
! 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
|
||||
|
|
@ -72,13 +55,13 @@ C: hand ( world -- hand )
|
|||
|
||||
: move-hand ( loc hand -- )
|
||||
dup hand-gadget parents-down >r
|
||||
2dup set-rectangle-loc
|
||||
2dup set-rect-loc
|
||||
[ >r world get pick-up r> set-hand-gadget ] keep
|
||||
dup hand-gadget parents-down r> hand-gestures ;
|
||||
|
||||
: update-hand ( hand -- )
|
||||
#! Called when a gadget is removed or added.
|
||||
dup rectangle-loc swap move-hand ;
|
||||
dup rect-loc swap move-hand ;
|
||||
|
||||
: focus-gestures ( new old -- )
|
||||
drop-prefix
|
||||
|
|
|
|||
|
|
@ -55,7 +55,7 @@ sequences vectors ;
|
|||
|
||||
: screen-loc ( gadget -- point )
|
||||
#! 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 )
|
||||
screen-loc swap screen-loc v- ;
|
||||
|
|
|
|||
|
|
@ -24,7 +24,7 @@ M: incremental layout* drop ;
|
|||
|
||||
: next-cursor ( gadget incremental -- cursor )
|
||||
[
|
||||
swap rectangle-dim swap incremental-cursor
|
||||
swap rect-dim swap incremental-cursor
|
||||
2dup v+ >r vmax r>
|
||||
] keep pack-vector set-axis ;
|
||||
|
||||
|
|
@ -33,10 +33,10 @@ M: incremental layout* drop ;
|
|||
|
||||
: incremental-loc ( gadget incremental -- )
|
||||
dup incremental-cursor swap pack-vector v*
|
||||
swap set-rectangle-loc ;
|
||||
swap set-rect-loc ;
|
||||
|
||||
: prefer-incremental ( gadget -- )
|
||||
dup pref-dim over set-rectangle-dim layout ;
|
||||
dup pref-dim over set-rect-dim layout ;
|
||||
|
||||
: add-incremental ( gadget incremental -- )
|
||||
2dup (add-gadget)
|
||||
|
|
|
|||
|
|
@ -27,7 +27,7 @@ TUPLE: pack align fill vector ;
|
|||
|
||||
: 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+
|
||||
] map-with ;
|
||||
|
||||
|
|
@ -42,9 +42,9 @@ TUPLE: pack align fill vector ;
|
|||
{ 0 0 0 } [ v+ ] accumulate ;
|
||||
|
||||
: 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
|
||||
>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 ;
|
||||
|
||||
: (packed-locs) ( gadget sizes -- seq )
|
||||
|
|
@ -52,7 +52,7 @@ TUPLE: pack align fill vector ;
|
|||
|
||||
: packed-locs ( gadget sizes -- )
|
||||
over gadget-children >r (packed-locs) r>
|
||||
[ set-rectangle-loc ] 2each ;
|
||||
[ set-rect-loc ] 2each ;
|
||||
|
||||
: packed-layout ( gadget sizes -- )
|
||||
2dup packed-locs packed-dims ;
|
||||
|
|
@ -83,6 +83,24 @@ M: pack pref-dim ( pack -- dim )
|
|||
|
||||
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.
|
||||
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/frames.factor"
|
||||
"/library/ui/world.factor"
|
||||
"/library/ui/timer.factor"
|
||||
"/library/ui/hand.factor"
|
||||
"/library/ui/labels.factor"
|
||||
"/library/ui/buttons.factor"
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ IN: gadgets
|
|||
USING: generic kernel lists math namespaces sequences ;
|
||||
|
||||
: 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 )
|
||||
<plain-gadget> { 1 1 0 } <border> ;
|
||||
|
|
|
|||
|
|
@ -7,32 +7,35 @@ namespaces sdl sequences strings styles vectors ;
|
|||
SYMBOL: clip
|
||||
|
||||
: >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
|
||||
#! of the gadget on the screen. The bottom/right is the
|
||||
#! intersected clip rectangle. Return f if the clip region
|
||||
#! is an empty region.
|
||||
surface get swap >sdl-rect SDL_SetClipRect ;
|
||||
#! intersected clip rectangle.
|
||||
surface get swap >sdl-rect SDL_SetClipRect drop ;
|
||||
|
||||
: with-clip ( shape quot -- )
|
||||
#! All drawing done inside the quotation is clipped to the
|
||||
#! shape's bounds.
|
||||
[
|
||||
>r screen-bounds clip [ intersect dup ] change set-clip
|
||||
[ r> call ] [ r> 2drop ] ifte
|
||||
] with-scope ; inline
|
||||
GENERIC: visible-children* ( rect gadget -- list )
|
||||
|
||||
M: gadget visible-children* ( rect gadget -- list )
|
||||
gadget-children [ screen-bounds intersects? ] subset-with ;
|
||||
|
||||
: visible-children ( gadget -- list )
|
||||
clip get swap visible-children* ;
|
||||
|
||||
GENERIC: draw-gadget* ( gadget -- )
|
||||
|
||||
: translate&clip ( gadget -- )
|
||||
screen-bounds dup rect-loc origin set
|
||||
clip [ intersect dup ] change ( set-clip ) drop ;
|
||||
|
||||
: draw-gadget ( gadget -- )
|
||||
dup gadget-visible? [
|
||||
dup [
|
||||
dup rectangle-loc origin [ v+ ] change
|
||||
translate&clip
|
||||
dup draw-gadget*
|
||||
gadget-children [ draw-gadget ] each
|
||||
] with-clip
|
||||
visible-children [ draw-gadget ] each
|
||||
] with-scope
|
||||
] [ drop ] ifte ;
|
||||
|
||||
: paint-prop* ( gadget key -- value )
|
||||
|
|
@ -73,14 +76,15 @@ M: f draw-boundary 2drop ;
|
|||
TUPLE: solid ;
|
||||
|
||||
: 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
|
||||
M: solid draw-interior
|
||||
drop >r surface get r> [ rect>screen ] keep bg rgb boxColor ;
|
||||
|
||||
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 ;
|
||||
|
||||
! Gradient pen
|
||||
|
|
@ -113,7 +117,7 @@ TUPLE: gradient vector from to ;
|
|||
dup first [ 3dup gradient-y ] repeat 2drop ;
|
||||
|
||||
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 } =
|
||||
[ horiz-gradient ] [ vert-gradient ] ifte ;
|
||||
|
||||
|
|
@ -144,7 +148,7 @@ SYMBOL: bevel-2
|
|||
M: bevel draw-boundary ( gadget boundary -- )
|
||||
#! Ugly code.
|
||||
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>
|
||||
rot draw-bevel
|
||||
] each-with ;
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@ TUPLE: scroller viewport x y ;
|
|||
: viewport-dim gadget-child pref-dim ;
|
||||
|
||||
: 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 -- )
|
||||
[ fix-scroll ] keep [ set-viewport-origin ] keep relayout ;
|
||||
|
|
@ -41,13 +41,13 @@ M: viewport pref-dim gadget-child pref-dim ;
|
|||
M: viewport layout* ( viewport -- )
|
||||
dup gadget-child dup prefer
|
||||
>r dup viewport-origin* swap fix-scroll r>
|
||||
set-rectangle-loc ;
|
||||
set-rect-loc ;
|
||||
|
||||
M: viewport focusable-child* ( viewport -- gadget )
|
||||
gadget-child ;
|
||||
|
||||
: 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
|
||||
v/ { 1 1 1 } vmin ;
|
||||
|
||||
|
|
@ -117,13 +117,13 @@ C: slider ( vector -- slider )
|
|||
: slider-dim { 12 12 12 } ;
|
||||
|
||||
: 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 layout* ( slider -- )
|
||||
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
|
||||
swap slider-thumb set-gadget-dim ;
|
||||
|
||||
|
|
|
|||
|
|
@ -17,7 +17,7 @@ TUPLE: splitter split ;
|
|||
|
||||
: divider-motion ( splitter -- )
|
||||
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 ;
|
||||
|
||||
: divider-actions ( thumb -- )
|
||||
|
|
@ -45,14 +45,14 @@ C: splitter ( first second split vector -- splitter )
|
|||
{ 1 0 0 } <splitter> ;
|
||||
|
||||
: 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- ;
|
||||
|
||||
: splitter-layout ( splitter -- { a b c } )
|
||||
[
|
||||
dup splitter-part ,
|
||||
divider-size ,
|
||||
dup rectangle-dim divider-size v- swap splitter-part v- ,
|
||||
dup rect-dim divider-size v- swap splitter-part v- ,
|
||||
] make-vector ;
|
||||
|
||||
M: splitter layout* ( splitter -- )
|
||||
|
|
|
|||
|
|
@ -61,7 +61,7 @@ IN: shells
|
|||
#! dimensions.
|
||||
ttf-init
|
||||
?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
|
||||
start-world
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@ DEFER: update-hand
|
|||
DEFER: do-timers
|
||||
|
||||
C: world ( -- world )
|
||||
f <stack> over set-delegate
|
||||
<stack> over set-delegate
|
||||
t over set-gadget-root?
|
||||
dup <hand> over set-world-hand ;
|
||||
|
||||
|
|
@ -47,7 +47,7 @@ M: world inside? ( point world -- ? ) 2drop t ;
|
|||
|
||||
: 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
|
||||
] with-surface ;
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue