removed remaining 2-dimensional point code from UI, minor enhancements to matrices library
Slava Pestov
parent
520eaa65ef
commit
a7279bd39c
|
|
@ -62,6 +62,9 @@ DEFER: subseq
|
|||
: 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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -14,19 +14,31 @@ vectors ;
|
|||
: 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 ;
|
||||
|
|
|
|||
|
|
@ -1,82 +0,0 @@
|
|||
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
|
||||
|
|
@ -136,3 +136,11 @@ 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
|
||||
|
|
|
|||
|
|
@ -91,7 +91,7 @@ SYMBOL: failures
|
|||
"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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -12,7 +12,7 @@ C: border ( child delegate size -- border )
|
|||
[ 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 ;
|
||||
|
|
|
|||
|
|
@ -27,28 +27,27 @@ TUPLE: editor line caret ;
|
|||
: 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 ;
|
||||
|
|
|
|||
|
|
@ -29,11 +29,11 @@ M: button-up-event handle-event ( event -- )
|
|||
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
|
||||
|
|
|
|||
|
|
@ -82,6 +82,9 @@ SYMBOL: frame-bottom-run
|
|||
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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -16,9 +16,11 @@ C: gadget ( shape -- 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
|
||||
|
||||
|
|
@ -44,9 +46,6 @@ 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 ;
|
||||
|
|
@ -73,9 +72,7 @@ GENERIC: layout* ( gadget -- )
|
|||
|
||||
: 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 -- ? )
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! 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 )
|
||||
|
|
@ -14,11 +14,8 @@ sequences ;
|
|||
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
|
||||
|
|
@ -41,18 +38,14 @@ SYMBOL: button-up
|
|||
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 ;
|
||||
|
||||
|
|
@ -61,7 +54,7 @@ SYMBOL: button-down
|
|||
#! 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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,18 +1,15 @@
|
|||
! 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 ;
|
||||
|
|
@ -24,11 +21,8 @@ DEFER: pick-up
|
|||
#! 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 ;
|
||||
|
|
@ -45,13 +39,13 @@ DEFER: pick-up
|
|||
! - 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 ;
|
||||
|
|
@ -66,10 +60,10 @@ C: hand ( world -- hand )
|
|||
[ 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 ;
|
||||
|
|
@ -83,15 +77,12 @@ C: hand ( world -- hand )
|
|||
#! 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
|
||||
|
|
@ -100,7 +91,7 @@ C: hand ( world -- hand )
|
|||
|
||||
: 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
|
||||
|
|
|
|||
|
|
@ -51,10 +51,6 @@ sequences ;
|
|||
#! 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 ;
|
||||
|
|
|
|||
|
|
@ -25,7 +25,7 @@ USING: generic io kernel listener math namespaces styles threads ;
|
|||
|
||||
<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 ;
|
||||
|
|
|
|||
|
|
@ -1,37 +1,7 @@
|
|||
! :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
|
||||
|
|
@ -52,7 +22,7 @@ SYMBOL: history-index
|
|||
: 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
|
||||
|
|
|
|||
|
|
@ -2,7 +2,6 @@ USING: kernel parser sequences io ;
|
|||
[
|
||||
"/library/ui/colors.factor"
|
||||
"/library/ui/shapes.factor"
|
||||
"/library/ui/points.factor"
|
||||
"/library/ui/rectangles.factor"
|
||||
"/library/ui/gadgets.factor"
|
||||
"/library/ui/hierarchy.factor"
|
||||
|
|
|
|||
|
|
@ -4,9 +4,7 @@ IN: gadgets
|
|||
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> ;
|
||||
|
|
|
|||
|
|
@ -1,54 +1,21 @@
|
|||
! 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
|
||||
|
|
@ -66,11 +33,9 @@ SYMBOL: clip
|
|||
dup gadget-paint [
|
||||
dup [
|
||||
[
|
||||
drop
|
||||
] [
|
||||
dup draw-shape dup [
|
||||
gadget-children [ draw-gadget ] each
|
||||
] with-trans
|
||||
] ifte
|
||||
] [ drop ] ifte
|
||||
] with-clip
|
||||
] bind ;
|
||||
|
|
|
|||
|
|
@ -1,25 +0,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 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 ;
|
||||
|
|
@ -1,58 +1,41 @@
|
|||
! 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 + ;
|
||||
M: rectangle shape-loc rectangle-loc ;
|
||||
M: rectangle set-shape-loc set-rectangle-loc ;
|
||||
|
||||
: fix-neg ( a b c -- a+c b -c )
|
||||
dup 0 < [ neg tuck >r >r + r> r> ] when ;
|
||||
M: rectangle shape-dim rectangle-dim ;
|
||||
M: rectangle set-shape-dim set-rectangle-dim ;
|
||||
|
||||
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 ;
|
||||
: screen-bounds ( shape -- rect )
|
||||
shape-bounds >r origin v+ r> <rectangle> ;
|
||||
|
||||
M: rectangle move-shape ( x y rect -- )
|
||||
tuck set-rectangle-y set-rectangle-x ;
|
||||
|
||||
M: rectangle resize-shape ( w h rect -- )
|
||||
tuck set-rectangle-h set-rectangle-w ;
|
||||
|
||||
: rectangle-x-extents ( rect x0 -- x1 x2 )
|
||||
>r dup shape-x r> + swap shape-w dupd + ;
|
||||
|
||||
: rectangle-y-extents ( rect y0 -- y1 y2 )
|
||||
>r dup shape-y r> + swap shape-h dupd + ;
|
||||
|
||||
: 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 inside? ( point rect -- ? )
|
||||
inside-rect? ;
|
||||
M: rectangle inside? ( loc rect -- ? )
|
||||
screen-bounds shape-bounds
|
||||
>r v- { 0 0 0 } r> vbetween? conj ;
|
||||
|
||||
M: rectangle draw-shape drop ;
|
||||
|
||||
: intersect ( shape shape -- rect )
|
||||
>r shape-extent r> shape-extent
|
||||
swapd vmin >r vmax dup r> swap v- { 0 0 0 } vmax
|
||||
<rectangle> ;
|
||||
|
||||
: 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 -- )
|
||||
|
|
@ -65,7 +48,7 @@ M: hollow-rect draw-shape ( rect -- )
|
|||
! 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 -- )
|
||||
|
|
@ -79,7 +62,7 @@ M: plain-rect draw-shape ( rect -- )
|
|||
! 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 -- )
|
||||
|
|
|
|||
|
|
@ -8,11 +8,6 @@ threads vectors styles ;
|
|||
|
||||
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 )
|
||||
|
|
|
|||
|
|
@ -1,42 +1,26 @@
|
|||
! 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 -- ? )
|
||||
: origin ( -- loc ) x get y get 0 3vector ;
|
||||
|
||||
! 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: 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 -- )
|
||||
|
||||
GENERIC: move-shape ( x y shape -- )
|
||||
: shape-x shape-loc first ;
|
||||
: shape-y shape-loc second ;
|
||||
: shape-w shape-dim first ;
|
||||
: shape-h shape-dim second ;
|
||||
|
||||
: set-shape-loc ( loc shape -- )
|
||||
>r 3unseq drop r> move-shape ;
|
||||
|
||||
GENERIC: resize-shape ( w h shape -- )
|
||||
|
||||
: set-shape-dim ( loc shape -- )
|
||||
>r 3unseq drop r> resize-shape ;
|
||||
|
||||
! 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
|
||||
|
|
@ -51,11 +35,15 @@ GENERIC: draw-shape ( obj -- )
|
|||
: 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-dim ( shape -- dim )
|
||||
dup shape-w swap shape-h 0 3vector ;
|
||||
: shape-extent ( shape -- loc dim )
|
||||
dup shape-loc dup rot shape-dim v+ ;
|
||||
|
||||
: shape-loc ( shape -- loc )
|
||||
dup shape-x swap shape-y 0 3vector ;
|
||||
: translate ( shape shape -- point )
|
||||
#! Translate a point relative to the shape.
|
||||
swap shape-loc swap shape-loc v- ;
|
||||
|
||||
M: vector shape-loc ;
|
||||
M: vector shape-dim drop { 0 0 0 } ;
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ IN: shells
|
|||
#! 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
|
||||
|
|
|
|||
|
|
@ -1,9 +1,9 @@
|
|||
! 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
|
||||
|
|
@ -30,22 +30,26 @@ C: world ( -- world )
|
|||
: 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 ;
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue