: third 2 swap nth ; inline
: fourth 3 swap nth ; inline
+: 2unseq ( { x y } -- x y )
+ dup first swap second ;
+
: 3unseq ( { x y z } -- x y z )
dup first over second rot third ;
: v- ( v v -- v ) [ - ] 2map ;
: v* ( v v -- v ) [ * ] 2map ;
: v/ ( v v -- v ) [ / ] 2map ;
-: v** ( v v -- v ) [ conjugate * ] 2map ;
+: vand ( v v -- v ) [ and ] 2map ;
+: vor ( v v -- v ) [ or ] 2map ;
: vmax ( v v -- v ) [ max ] 2map ;
: vmin ( v v -- v ) [ min ] 2map ;
+: v< ( v v -- v ) [ < ] 2map ;
+: v<= ( v v -- v ) [ <= ] 2map ;
+: v> ( v v -- v ) [ > ] 2map ;
+: v>= ( v v -- v ) [ >= ] 2map ;
+
+: vbetween? ( v from to -- v )
+ >r over >r v>= r> r> v<= vand ;
+
: vneg ( v -- v ) [ neg ] map ;
: sum ( v -- n ) 0 [ + ] reduce ;
: product 1 [ * ] reduce ;
+: conj ( v -- ? ) t [ and ] reduce ;
+: disj ( v -- ? ) f [ or ] reduce ;
: set-axis ( x y axis -- v )
2dup v* >r >r drop dup r> v* v- r> v+ ;
! Later, this will fixed when 2each works properly
! : v. ( v v -- x ) 0 swap [ conjugate * + ] 2each ;
+: v** ( v v -- v ) [ conjugate * ] 2map ;
: v. ( v v -- x ) v** sum ;
: norm-sq ( v -- n ) 0 [ absq + ] reduce ;
+++ /dev/null
-IN: temporary
-USING: gadgets kernel lists math namespaces test sequences ;
-
-[ t ] [
- [
- 2000 x set
- 2000 y set
- 2030 2040 rect> 10 20 300 400 <rectangle> inside?
- ] with-scope
-] unit-test
-[ f ] [
- [
- 2000 x set
- 2000 y set
- 2500 2040 rect> 10 20 300 400 <rectangle> inside?
- ] with-scope
-] unit-test
-[ t ] [
- [
- -10 x set
- -20 y set
- 0 0 rect> 10 20 300 400 <rectangle> inside?
- ] with-scope
-] unit-test
-[ 11 11 41 41 ] [
- [
- 1 x set
- 1 y set
- 10 10 30 30 <rectangle> <gadget> rect>screen
- ] with-scope
-] unit-test
-[ t ] [
- [
- 0 x set
- 0 y set
- 0 0 rect> -10 -10 20 20 <rectangle> <gadget> [ pick-up ] keep =
- ] with-scope
-] unit-test
-
-: funny-rect ( x -- rect )
- 10 10 30 <rectangle> <gadget>
- dup [ 255 0 0 ] foreground set-paint-prop ;
-
-[ f ] [
- [
- 0 x set
- 0 y set
- 35 0 rect>
- [ 10 30 50 70 ] [ funny-rect ] map
- pick-up-list
- ] with-scope
-] unit-test
-
-[ -90 ] [ 10 10 -100 -200 <line> shape-x ] unit-test
-[ 20 ] [ 10 10 100 200 <line> [ 20 30 rot move-shape ] keep shape-x ] unit-test
-[ 30 ] [ 10 10 100 200 <line> [ 20 30 rot move-shape ] keep shape-y ] unit-test
-[ 20 ] [ 110 110 -100 -200 <line> [ 20 30 rot move-shape ] keep shape-x ] unit-test
-[ 30 ] [ 110 110 -100 -200 <line> [ 20 30 rot move-shape ] keep shape-y ] unit-test
-[ 10 ] [ 110 110 -100 -200 <line> [ 400 400 rot resize-shape ] keep shape-x ] unit-test
-[ 400 ] [ 110 110 -100 -200 <line> [ 400 400 rot resize-shape ] keep shape-w ] unit-test
-
-[ t ] [
- [
- 100 x set
- 100 y set
- #{ 110 115 }# << line f 0 0 100 150 >> inside?
- ] with-scope
-] unit-test
-
-[ ] [ "pile" get layout* ] unit-test
-
-[
- 1 15
-] [
- 1 15 << line [ ] 0 0 0 14 >> [ resize-shape ] keep shape-size
-] unit-test
-
-[
- 1 15
-] [
- 1 15 << line [ ] 0 22 -1 14 >> [ resize-shape ] keep shape-size
-] unit-test
M[ [ 1 2 3 ] [ 4 5 6 ] [ 7 8 9 ] ]M
5 [ 2 - swap <diagonal> ] project-with [ >list ] map
] unit-test
+
+[ { t t t } ]
+[ { 1 2 3 } { -1 -2 -3 } { 4 5 6 } vbetween? ]
+unit-test
+
+[ { t f t } ]
+[ { 1 10 3 } { -1 -2 -3 } { 4 5 6 } vbetween? ]
+unit-test
"crashes" "sbuf" "threads" "parsing-word"
"inference" "interpreter"
"alien"
- "line-editor" "gadgets" "memory" "redefine"
+ "line-editor" "gadgets/rectangles" "memory" "redefine"
"annotate" "sequences" "binary" "inspector"
] run-tests ;
[ over [ add-gadget ] [ 2drop ] ifte ] keep ;
: line-border ( child -- border )
- 0 0 0 0 <etched-rect> <gadget> { 5 5 0 } <border> ;
+ { 0 0 0 } dup <etched-rect> <gadget> { 5 5 0 } <border> ;
: layout-border-loc ( border -- )
dup border-size swap gadget-child set-shape-loc ;
: unfocus-editor ( editor -- )
editor-caret unparent ;
-: run-char-widths ( str -- wlist )
+: run-char-widths ( font str -- wlist )
#! List of x co-ordinates of each character.
- 0 swap >list
- [ ch>string shape-w [ + dup ] keep 2 /i - ] map nip ;
+ >list [ ch>string size-string drop ] map-with
+ dup 0 [ + ] accumulate swap 2 v/n v+ ;
: (x>offset) ( n x wlist -- offset )
dup [
- uncons >r over > [
- r> 2drop
- ] [
- >r 1 + r> r> (x>offset)
- ] ifte
+ uncons >r over >
+ [ r> 2drop ] [ >r 1 + r> r> (x>offset) ] ifte
] [
2drop
] ifte ;
-: x>offset ( x str -- offset )
- 0 -rot run-char-widths (x>offset) ;
+: x>offset ( x font str -- offset )
+ run-char-widths 0 -rot (x>offset) ;
: set-caret-x ( x editor -- )
#! Move the caret to a clicked location.
- [ line-text get x>offset caret set ] with-editor ;
+ dup [
+ gadget-font line-text get x>offset caret set
+ ] with-editor ;
: click-editor ( editor -- )
dup hand relative shape-x over set-caret-x request-focus ;
button-event-button dup hand button\
[ button-up ] button-gesture ;
-: motion-event-pos ( event -- x y )
- dup motion-event-x swap motion-event-y ;
+: motion-event-loc ( event -- loc )
+ dup motion-event-x swap motion-event-y 0 3vector ;
M: motion-event handle-event ( event -- )
- motion-event-pos hand move-hand ;
+ motion-event-loc hand move-hand ;
M: key-down-event handle-event ( event -- )
dup keyboard-event>binding
dup var-frame-right
var-frame-bottom ;
+: move-gadget ( x y gadget -- )
+ >r 0 3vector r> set-shape-loc ;
+
: reshape-gadget ( x y w h gadget -- )
[ >r 0 3vector r> set-gadget-dim ] keep move-gadget ;
<namespace> over set-gadget-paint
<namespace> over set-gadget-gestures ;
-: <empty-gadget> ( -- gadget ) 0 0 0 0 <rectangle> <gadget> ;
+: <empty-gadget> ( -- gadget )
+ { 0 0 0 } dup <rectangle> <gadget> ;
-: <plain-gadget> ( -- gadget ) 0 0 0 0 <plain-rect> <gadget> ;
+: <plain-gadget> ( -- gadget )
+ { 0 0 0 } dup <plain-rect> <gadget> ;
DEFER: add-invalid
#! Relayout a gadget and its children.
dup add-invalid (relayout-down) ;
-: move-gadget ( x y gadget -- )
- >r 0 3vector r> set-shape-loc ;
-
: set-gadget-dim ( dim gadget -- )
2dup shape-dim =
[ 2drop ] [ [ set-shape-dim ] keep relayout-down ] ifte ;
: prefer ( gadget -- ) dup pref-dim swap set-gadget-dim ;
-M: gadget layout*
- #! Trivial layout gives each child its preferred size.
- gadget-children [ prefer ] each ;
+M: gadget layout* drop ;
GENERIC: user-input* ( ch gadget -- ? )
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: gadgets
-USING: alien generic hashtables kernel lists math sdl
+USING: alien generic hashtables kernel lists math matrices sdl
sequences ;
: action ( gadget gesture -- quot )
swap [ unswons set-action ] each-with ;
: handle-gesture* ( gesture gadget -- ? )
- tuck gadget-gestures hash* dup [
- cdr call f
- ] [
- 2drop t
- ] ifte ;
+ tuck gadget-gestures hash* dup
+ [ cdr call f ] [ 2drop t ] ifte ;
: handle-gesture ( gesture gadget -- ? )
#! If a gadget's handle-gesture* generic returns t, the
SYMBOL: button-down
: hierarchy-gesture ( gadget ? gesture -- ? )
- swap [
- 2drop f
- ] [
- swap handle-gesture* drop t
- ] ifte ;
+ swap [ 2drop f ] [ swap handle-gesture* drop t ] ifte ;
: mouse-enter ( point gadget -- )
#! If the old point is inside the new gadget, do not fire an
#! enter gesture, since the mouse did not enter. Otherwise,
#! fire an enter gesture and go on to the parent.
[
- [ shape-pos + ] keep
+ [ shape-loc v+ ] keep
2dup inside? [ mouse-enter ] hierarchy-gesture
] each-parent 2drop ;
#! leave gesture, since the mouse did not leave. Otherwise,
#! fire a leave gesture and go on to the parent.
[
- [ shape-pos + ] keep
+ [ shape-loc v+ ] keep
2dup inside? [ mouse-leave ] hierarchy-gesture
] each-parent 2drop ;
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: gadgets
-USING: alien generic io kernel lists math namespaces prettyprint
-sdl sequences vectors ;
+USING: alien generic io kernel lists math matrices namespaces
+prettyprint sdl sequences vectors ;
DEFER: pick-up
: pick-up-list ( point list -- gadget )
dup [
- 2dup car pick-up dup [
- 2nip
- ] [
- drop cdr pick-up-list
- ] ifte
+ 2dup car pick-up dup
+ [ 2nip ] [ drop cdr pick-up-list ] ifte
] [
2drop f
] ifte ;
#! box delegate.
2dup inside? [
2dup [ translate ] keep
- gadget-children reverse pick-up-list dup [
- 2nip
- ] [
- 3drop t
- ] ifte
+ gadget-children reverse pick-up-list dup
+ [ 2nip ] [ 3drop t ] ifte
] [
2drop f
] ifte ;
! - hand-gadget is the gadget under the mouse position
! - hand-clicked is the most recently clicked gadget
! - hand-focus is the gadget holding keyboard focus
-TUPLE: hand world
+TUPLE: hand
+ world
click-loc click-rel clicked buttons
gadget focus ;
C: hand ( world -- hand )
- <empty-gadget>
- over set-delegate
+ <empty-gadget> over set-delegate
[ set-hand-world ] 2keep
[ set-gadget-parent ] 2keep
[ set-hand-gadget ] keep ;
[ hand-buttons remove ] keep set-hand-buttons ;
: fire-leave ( hand gadget -- )
- [ swap shape-pos swap screen-pos - ] keep mouse-leave ;
+ [ swap shape-loc swap screen-loc v- ] keep mouse-leave ;
: fire-enter ( oldpos hand -- )
- hand-gadget [ screen-pos - ] keep mouse-enter ;
+ hand-gadget [ screen-loc v- ] keep mouse-enter ;
: update-hand-gadget ( hand -- )
dup dup hand-world pick-up swap set-hand-gadget ;
#! and if a mouse button is down, fire a drag gesture to the
#! gadget that was clicked.
[ motion ] over hand-gadget handle-gesture drop
- dup hand-buttons [
- dup hand-clicked [ drag ] motion-gesture
- ] [
- drop
- ] ifte ;
+ dup hand-buttons
+ [ dup hand-clicked [ drag ] motion-gesture ] [ drop ] ifte ;
-: move-hand ( x y hand -- )
- dup shape-pos >r
- [ move-gadget ] keep
+: move-hand ( loc hand -- )
+ dup shape-loc >r
+ [ set-shape-loc ] keep
dup hand-gadget >r
dup update-hand-gadget
dup r> fire-leave
: update-hand ( hand -- )
#! Called when a gadget is removed or added.
- [ dup shape-x swap shape-y ] keep move-hand ;
+ dup shape-loc swap move-hand ;
: request-focus ( gadget -- )
focusable-child
#! parents until it returns f.
>r parents r> (each-parent) ; inline
-: screen-pos ( gadget -- point )
- #! The position of the gadget on the screen.
- 0 swap [ shape-pos + t ] each-parent drop ;
-
: screen-loc ( gadget -- point )
#! The position of the gadget on the screen.
{ 0 0 0 } swap [ shape-loc v+ t ] each-parent drop ;
<scroller> "Stack display goes here" <label> 3/4 <y-splitter> add-layer
- dup [ [ clear print-banner listener ] in-thread ] with-stream
+ [ [ clear print-banner listener ] with-stream ] in-thread
request-focus
] bind ;
-! :folding=indent:collapseFolds=1:
-
-! $Id$
-!
! Copyright (C) 2005 Slava Pestov.
-!
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice,
-! this list of conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-! this list of conditions and the following disclaimer in the documentation
-! and/or other materials provided with the distribution.
-!
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
+! See http://factor.sf.net/license.txt for BSD license.
IN: line-editor
-USE: namespaces
-USE: strings
-USE: kernel
-USE: math
-USE: sequences
-USE: vectors
+USING: kernel math namespaces sequences strings vectors ;
SYMBOL: line-text
SYMBOL: caret
: commit-history ( -- )
#! Call this in the line editor scope. Adds the currently
#! entered text to the history.
- line-text get dup "" = [
+ line-text get dup empty? [
drop
] [
history-index get history get set-nth
[
"/library/ui/colors.factor"
"/library/ui/shapes.factor"
- "/library/ui/points.factor"
"/library/ui/rectangles.factor"
"/library/ui/gadgets.factor"
"/library/ui/hierarchy.factor"
USING: generic kernel lists math namespaces sequences ;
: show-menu ( menu -- )
- hide-glass
- hand screen-loc over set-shape-loc
- show-glass ;
+ hand screen-loc over set-shape-loc show-glass ;
: menu-item-border ( child -- border )
<plain-gadget> { 1 1 0 } <border> ;
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: gadgets
-USING: generic hashtables kernel lists math namespaces sdl
-io strings sequences ;
-
-! Clipping
+USING: generic hashtables io kernel lists math matrices
+namespaces sdl sequences strings ;
SYMBOL: clip
-: intersect* ( gadget rect quot -- t1 t2 )
- call >r >r max r> r> min 2dup > [ drop dup ] when ; inline
-
-: intersect-x ( gadget rect -- x1 x2 )
- [
- 0 rectangle-x-extents >r swap 0 rectangle-x-extents r>
- ] intersect* ;
-
-: intersect-y ( gadget rect -- y1 y2 )
- [
- 0 rectangle-y-extents >r swap 0 rectangle-y-extents r>
- ] intersect* ;
-
-: screen-bounds ( shape -- rect )
- [ shape-x x get + ] keep
- [ shape-y y get + ] keep
- [ shape-w ] keep
- shape-h
- <rectangle> ;
-
-: clip-rect ( x1 x2 y1 y2 -- rect )
- over - 0 max >r >r over - 0 max r> swap r>
- <rectangle> ;
-
-: intersect ( rect rect -- rect )
- [ intersect-x ] 2keep intersect-y clip-rect ;
-
: >sdl-rect ( rectangle -- sdlrect )
- [ rectangle-x ] keep
- [ rectangle-y ] keep
- [ rectangle-w ] keep
- rectangle-h
+ [ shape-x ] keep [ shape-y ] keep [ shape-w ] keep shape-h
make-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 t if the clip region
+ #! intersected clip rectangle. Return f if the clip region
#! is an empty region.
- surface get swap [ >sdl-rect SDL_SetClipRect drop ] keep
- dup shape-w 0 = swap shape-h 0 = or ;
+ surface get swap >sdl-rect SDL_SetClipRect ;
: with-clip ( shape quot -- )
#! All drawing done inside the quotation is clipped to the
dup gadget-paint [
dup [
[
- drop
- ] [
dup draw-shape dup [
gadget-children [ draw-gadget ] each
] with-trans
- ] ifte
+ ] [ drop ] ifte
] with-clip
] bind ;
+++ /dev/null
-! Copyright (C) 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: gadgets
-USING: generic kernel lists math namespaces sdl sequences
-vectors ;
-
-M: number inside? ( point point -- )
- >r shape-pos r> = ;
-
-M: number shape-x real ;
-M: number shape-y imaginary ;
-M: number shape-w drop 0 ;
-M: number shape-h drop 0 ;
-
-: translate ( point shape -- point )
- #! Translate a point relative to the shape.
- swap shape-pos swap shape-pos - ;
-
-M: vector inside? ( point point -- )
- >r shape-loc r> = ;
-
-M: vector shape-x first ;
-M: vector shape-y second ;
-M: vector shape-w drop 0 ;
-M: vector shape-h drop 0 ;
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: gadgets
-USING: generic kernel lists math namespaces sdl styles ;
+USING: generic kernel lists math matrices namespaces sdl styles
+vectors ;
-! A rectangle maps trivially to the shape protocol.
-TUPLE: rectangle x y w h ;
-M: rectangle shape-x rectangle-x ;
-M: rectangle shape-y rectangle-y ;
-M: rectangle shape-w rectangle-w ;
-M: rectangle shape-h rectangle-h ;
+TUPLE: rectangle loc dim ;
-: rect>screen ( shape -- x1 y1 x2 y2 )
- [ rectangle-x x get + ] keep
- [ rectangle-y y get + ] keep
- [ rectangle-w pick + ] keep
- rectangle-h pick + ;
-
-: fix-neg ( a b c -- a+c b -c )
- dup 0 < [ neg tuck >r >r + r> r> ] when ;
-
-C: rectangle ( x y w h -- rect )
- #! We handle negative w/h for convinience.
- >r fix-neg >r fix-neg r> r>
- [ set-rectangle-h ] keep
- [ set-rectangle-w ] keep
- [ set-rectangle-y ] keep
- [ set-rectangle-x ] keep ;
-
-M: rectangle move-shape ( x y rect -- )
- tuck set-rectangle-y set-rectangle-x ;
+M: rectangle shape-loc rectangle-loc ;
+M: rectangle set-shape-loc set-rectangle-loc ;
-M: rectangle resize-shape ( w h rect -- )
- tuck set-rectangle-h set-rectangle-w ;
+M: rectangle shape-dim rectangle-dim ;
+M: rectangle set-shape-dim set-rectangle-dim ;
-: rectangle-x-extents ( rect x0 -- x1 x2 )
- >r dup shape-x r> + swap shape-w dupd + ;
+: screen-bounds ( shape -- rect )
+ shape-bounds >r origin v+ r> <rectangle> ;
-: rectangle-y-extents ( rect y0 -- y1 y2 )
- >r dup shape-y r> + swap shape-h dupd + ;
+M: rectangle inside? ( loc rect -- ? )
+ screen-bounds shape-bounds
+ >r v- { 0 0 0 } r> vbetween? conj ;
-: inside-rect? ( point rect -- ? )
- over shape-x over x get rectangle-x-extents 1 - between? >r
- swap shape-y swap y get rectangle-y-extents 1 - between? r>
- and ;
+M: rectangle draw-shape drop ;
-M: rectangle inside? ( point rect -- ? )
- inside-rect? ;
+: intersect ( shape shape -- rect )
+ >r shape-extent r> shape-extent
+ swapd vmin >r vmax dup r> swap v- { 0 0 0 } vmax
+ <rectangle> ;
-M: rectangle draw-shape drop ;
+: rect>screen ( shape -- x1 y1 x2 y2 )
+ [ shape-x x get + ] keep
+ [ shape-y y get + ] keep
+ [ shape-w pick + ] keep
+ shape-h pick + ;
! A rectangle only whose outline is visible.
TUPLE: hollow-rect ;
-C: hollow-rect ( x y w h -- rect )
+C: hollow-rect ( loc dim -- rect )
[ >r <rectangle> r> set-delegate ] keep ;
: hollow-rect ( shape -- )
! A rectangle that is filled.
TUPLE: plain-rect ;
-C: plain-rect ( x y w h -- rect )
+C: plain-rect ( loc dim -- rect )
[ >r <rectangle> r> set-delegate ] keep ;
: plain-rect ( shape -- )
! has an outline.
TUPLE: etched-rect ;
-C: etched-rect ( x y w h -- rect )
+C: etched-rect ( loc dim -- rect )
[ >r <rectangle> r> set-delegate ] keep ;
M: etched-rect draw-shape ( rect -- )
TUPLE: viewport origin ;
-: viewport-x viewport-origin first ;
-: viewport-y viewport-origin second ;
-: set-viewport-x [ viewport-y 0 3vector ] keep set-viewport-origin ;
-: set-viewport-y [ viewport-x swap 0 3vector ] keep set-viewport-origin ;
-
: viewport-dim ( viewport -- h ) gadget-child pref-dim ;
: fix-scroll ( origin viewport -- origin )
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: gadgets
-USING: generic kernel lists math namespaces sdl sequences
-vectors ;
+USING: generic kernel lists math matrices namespaces sdl
+sequences vectors ;
-! Shape protocol. Shapes are immutable; moving or resizing a
-! shape makes a new shape.
-
-! These dynamically-bound variables affect the generic word
-! inside? and others.
SYMBOL: x
SYMBOL: y
-GENERIC: inside? ( point shape -- ? )
-
-! A shape is an object with a defined bounding
-! box, and a notion of interior.
-GENERIC: shape-x
-GENERIC: shape-y
-GENERIC: shape-w
-GENERIC: shape-h
-
-GENERIC: move-shape ( x y shape -- )
-
-: set-shape-loc ( loc shape -- )
- >r 3unseq drop r> move-shape ;
+: origin ( -- loc ) x get y get 0 3vector ;
-GENERIC: resize-shape ( w h shape -- )
+GENERIC: inside? ( loc shape -- ? )
+GENERIC: shape-loc ( shape -- loc )
+GENERIC: set-shape-loc ( loc shape -- )
+GENERIC: shape-dim ( shape -- dim )
+GENERIC: set-shape-dim ( dim shape -- )
-: set-shape-dim ( loc shape -- )
- >r 3unseq drop r> resize-shape ;
+: shape-x shape-loc first ;
+: shape-y shape-loc second ;
+: shape-w shape-dim first ;
+: shape-h shape-dim second ;
-! The painting protocol. Painting is controlled by various
-! dynamically-scoped variables. See library/styles.factor.
-
-GENERIC: draw-shape ( obj -- )
-
-! Utility words
+GENERIC: draw-shape ( shape -- )
: with-trans ( shape quot -- )
#! All drawing done inside the quotation is translated
: shape-pos ( shape -- pos )
dup shape-x swap shape-y rect> ;
-: shape-size ( shape -- w h )
- dup shape-w swap shape-h ;
+: shape-bounds ( shape -- loc dim )
+ dup shape-loc swap shape-dim ;
+
+: shape-extent ( shape -- loc dim )
+ dup shape-loc dup rot shape-dim v+ ;
-: shape-dim ( shape -- dim )
- dup shape-w swap shape-h 0 3vector ;
+: translate ( shape shape -- point )
+ #! Translate a point relative to the shape.
+ swap shape-loc swap shape-loc v- ;
-: shape-loc ( shape -- loc )
- dup shape-x swap shape-y 0 3vector ;
+M: vector shape-loc ;
+M: vector shape-dim drop { 0 0 0 } ;
#! Start the Factor graphics subsystem with the given screen
#! dimensions.
?init-world
- world get shape-size 0 SDL_RESIZABLE [
+ world get shape-dim 2unseq 0 SDL_RESIZABLE [
0 x set 0 y set [
"Factor " version append dup SDL_WM_SetCaption
ttf-init
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: gadgets
-USING: alien errors generic kernel lists math
-memory namespaces prettyprint sdl sequences io strings
-threads sequences ;
+USING: alien errors generic io kernel lists math memory
+namespaces prettyprint sdl sequences sequences strings threads
+vectors ;
! The world gadget is the top level gadget that all (visible)
! gadgets are contained in. The current world is stored in the
: add-layer ( gadget -- )
world get add-gadget ;
-: show-glass ( gadget -- )
- <empty-gadget> dup
- world get 2dup add-gadget set-world-glass
- add-gadget ;
-
: hide-glass ( -- )
world get world-glass unparent f
world get set-world-glass ;
+: show-glass ( gadget -- )
+ hide-glass
+ <empty-gadget> dup
+ world get 2dup add-gadget set-world-glass
+ dupd add-gadget prefer ;
+
M: world inside? ( point world -- ? ) 2drop t ;
: hand world get world-hand ;
: draw-world ( world -- )
[
- dup 0 0 width get height get <rectangle> clip set-paint-prop
+ dup
+ { 0 0 0 }
+ width get height get 0 3vector <rectangle>
+ clip set-paint-prop
draw-gadget
] with-surface ;