From e9b142db4d38f8e6660ceaf918125441285f2ee1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Jun 2005 06:32:17 +0000 Subject: [PATCH] slowly refactoring UI code to use 3-vectors instead of a mix of x/y parameters on the stack, and complex numbers representing points, added horizontal scrolling --- library/bootstrap/primitives.factor | 1 - library/collections/sequences.factor | 3 + library/collections/vectors-epilogue.factor | 6 + library/math/matrices.factor | 4 + library/test/sequences.factor | 2 + library/ui/gadgets.factor | 25 ++-- library/ui/hand.factor | 10 +- library/ui/hierarchy.factor | 8 +- library/ui/points.factor | 14 ++- library/ui/scrolling.factor | 120 ++++++++++++-------- library/ui/shapes.factor | 16 ++- library/ui/tiles.factor | 14 +-- 12 files changed, 143 insertions(+), 80 deletions(-) diff --git a/library/bootstrap/primitives.factor b/library/bootstrap/primitives.factor index 3af6bc766a..c2b3eb0f54 100644 --- a/library/bootstrap/primitives.factor +++ b/library/bootstrap/primitives.factor @@ -203,7 +203,6 @@ vocabularies get [ [ "die" "kernel" [ [ ] [ ] ] ] [ "flush-icache" "assembler" f ] [ "fopen" "io-internals" [ [ string string ] [ alien ] ] ] - [ "fgets" "io-internals" [ [ alien ] [ string ] ] ] [ "fgetc" "io-internals" [ [ alien ] [ object ] ] ] [ "fwrite" "io-internals" [ [ string alien ] [ ] ] ] [ "fflush" "io-internals" [ [ alien ] [ ] ] ] diff --git a/library/collections/sequences.factor b/library/collections/sequences.factor index be8d137956..0e18791a80 100644 --- a/library/collections/sequences.factor +++ b/library/collections/sequences.factor @@ -56,6 +56,9 @@ DEFER: subseq : third 2 swap nth ; inline : fourth 3 swap nth ; inline +: 3unseq ( { x y z } -- x y z ) + dup first over second rot third ; + ! Some low-level code used by vectors and string buffers. IN: kernel-internals diff --git a/library/collections/vectors-epilogue.factor b/library/collections/vectors-epilogue.factor index d150e74ce5..9f6da2254c 100644 --- a/library/collections/vectors-epilogue.factor +++ b/library/collections/vectors-epilogue.factor @@ -25,3 +25,9 @@ M: general-list thaw >vector ; M: general-list like drop >list ; M: vector like drop >vector ; + +: 3vector ( x y z -- { x y z } ) + 3 + [ >r rot r> push ] keep + [ swapd push ] keep + [ push ] keep ; diff --git a/library/math/matrices.factor b/library/math/matrices.factor index ec438e4326..d9d16f2b5d 100644 --- a/library/math/matrices.factor +++ b/library/math/matrices.factor @@ -10,7 +10,11 @@ vectors ; : v+ ( v v -- v ) [ + ] 2map ; : v- ( v v -- v ) [ - ] 2map ; : v* ( v v -- v ) [ * ] 2map ; +: v/ ( v v -- v ) [ / ] 2map ; : v** ( v v -- v ) [ conjugate * ] 2map ; +: vmax ( v v -- v ) [ max ] 2map ; +: vmin ( v v -- v ) [ min ] 2map ; +: vneg ( v -- v ) [ neg ] map ; : sum ( v -- n ) 0 swap [ + ] each ; : product 1 swap [ * ] each ; diff --git a/library/test/sequences.factor b/library/test/sequences.factor index b7b3708887..894068bf1c 100644 --- a/library/test/sequences.factor +++ b/library/test/sequences.factor @@ -12,3 +12,5 @@ USING: lists sequences test vectors ; [ { 3 4 } ] [ 2 4 1 10 subseq ] unit-test [ { 3 4 } ] [ 0 2 2 4 1 10 subseq ] unit-test [ "cba" ] [ 3 "abcdef" head-slice reverse ] unit-test + +[ 1 2 3 ] [ 1 2 3 3vector 3unseq ] unit-test diff --git a/library/ui/gadgets.factor b/library/ui/gadgets.factor index dc1d50a24c..52e99c2791 100644 --- a/library/ui/gadgets.factor +++ b/library/ui/gadgets.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: gadgets -USING: generic hashtables kernel lists math namespaces -sequences ; +USING: generic hashtables kernel lists math namespaces sequences +vectors ; ! A gadget is a shape, a paint, a mapping of gestures to ! actions, and a reference to the gadget's parent. A gadget @@ -43,21 +43,19 @@ C: gadget ( shape -- gadget ) #! Relayout a gadget and its children. dup relayout gadget-children [ relayout* ] each ; -: ?move ( x y gadget quot -- ) - >r 3dup shape-pos >r rect> r> = [ - 3drop - ] r> ifte ; inline +: set-gadget-loc ( loc gadget -- ) + 2dup shape-loc = + [ 2drop ] [ [ set-shape-loc ] keep redraw ] ifte ; : move-gadget ( x y gadget -- ) - [ [ move-shape ] keep redraw ] ?move ; + >r 0 3vector r> set-gadget-loc ; -: ?resize ( w h gadget quot -- ) - >r 3dup shape-size rect> >r rect> r> = [ - 3drop - ] r> ifte ; inline +: set-gadget-dim ( dim gadget -- ) + 2dup shape-dim = + [ 2drop ] [ [ set-shape-dim ] keep relayout* ] ifte ; : resize-gadget ( w h gadget -- ) - [ [ resize-shape ] keep relayout* ] ?resize ; + >r 0 3vector r> set-gadget-dim ; : paint-prop ( gadget key -- value ) over [ @@ -74,8 +72,11 @@ C: gadget ( shape -- gadget ) rot gadget-paint set-hash ; GENERIC: pref-size ( gadget -- w h ) + M: gadget pref-size shape-size ; +: pref-dim pref-size 0 3vector ; + GENERIC: layout* ( gadget -- ) : prefer ( gadget -- ) [ pref-size ] keep resize-gadget ; diff --git a/library/ui/hand.factor b/library/ui/hand.factor index d4f1b78800..c50599f716 100644 --- a/library/ui/hand.factor +++ b/library/ui/hand.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: gadgets -USING: alien generic kernel lists math namespaces prettyprint -sequences sdl io ; +USING: alien generic io kernel lists math namespaces prettyprint +sdl sequences vectors ; DEFER: pick-up @@ -46,9 +46,11 @@ DEFER: pick-up ! - hand-clicked is the most recently clicked gadget ! - hand-focus is the gadget holding keyboard focus TUPLE: hand world - click-pos click-rel clicked buttons + click-loc click-rel clicked buttons gadget focus ; +: hand-click-pos hand-click-loc 3unseq drop rect> ; + C: hand ( world -- hand ) over set-delegate @@ -58,7 +60,7 @@ C: hand ( world -- hand ) : button/ ( n hand -- ) dup hand-gadget over set-hand-clicked - dup screen-pos over set-hand-click-pos + dup screen-loc over set-hand-click-loc dup hand-gadget over relative over set-hand-click-rel [ hand-buttons unique ] keep set-hand-buttons ; diff --git a/library/ui/hierarchy.factor b/library/ui/hierarchy.factor index 2fa7b7653b..457b5e5309 100644 --- a/library/ui/hierarchy.factor +++ b/library/ui/hierarchy.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: gadgets -USING: generic hashtables kernel lists math namespaces +USING: generic hashtables kernel lists math matrices namespaces sequences ; : remove-gadget ( gadget box -- ) @@ -54,8 +54,12 @@ sequences ; #! 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 ; + : relative ( g1 g2 -- g2-g1 ) - screen-pos swap screen-pos - ; + screen-loc swap screen-loc v- ; : child? ( parent child -- ? ) dup [ diff --git a/library/ui/points.factor b/library/ui/points.factor index c9a788854f..41c7b1dae0 100644 --- a/library/ui/points.factor +++ b/library/ui/points.factor @@ -1,11 +1,9 @@ ! Copyright (C) 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: gadgets -USING: generic kernel lists math namespaces sdl ; +USING: generic kernel lists math namespaces sdl sequences +vectors ; -! A point, represented as a complex number, is the simplest -! shape. It is not mutable and cannot be used as the delegate of -! a gadget. M: number inside? ( point point -- ) >r shape-pos r> = ; @@ -17,3 +15,11 @@ 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 ; diff --git a/library/ui/scrolling.factor b/library/ui/scrolling.factor index 90576afa14..00c066983b 100644 --- a/library/ui/scrolling.factor +++ b/library/ui/scrolling.factor @@ -1,55 +1,68 @@ ! Copyright (C) 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: gadgets -USING: generic kernel lists math namespaces threads ; +USING: generic kernel lists math matrices namespaces sequences +threads vectors ; ! A viewport can be scrolled. -TUPLE: viewport x y ; +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-h ( viewport -- h ) gadget-child pref-size nip ; -: adjust-scroll ( y viewport -- y ) - #! Make sure we don't scroll above the first line, or beyond - #! the end of the document. - dup shape-h swap viewport-h - max 0 min ; +: viewport-dim ( viewport -- h ) gadget-child pref-dim ; + +: fix-scroll ( origin viewport -- origin ) + dup shape-dim swap viewport-dim v- vmax { 0 0 0 } vmin ; + +: scroll ( origin viewport -- ) + [ fix-scroll ] keep [ set-viewport-origin ] keep relayout ; : scroll-viewport ( y viewport -- ) #! y is a number between -1 and 0.. [ viewport-h * >fixnum ] keep - [ adjust-scroll ] keep - [ set-viewport-y ] keep - relayout ; + [ viewport-x swap 0 3vector ] keep + scroll ; C: viewport ( content -- viewport ) [ swap set-delegate ] keep [ add-gadget ] keep - 0 over set-viewport-x - 0 over set-viewport-y ; + { 0 0 0 } over set-viewport-origin ; M: viewport pref-size gadget-child pref-size ; M: viewport layout* ( viewport -- ) - dup gadget-child dup prefer - >r dup viewport-x swap viewport-y r> move-gadget ; + dup viewport-origin + swap gadget-child dup prefer set-gadget-loc ; + +: visible-portion ( viewport -- vector ) + dup shape-dim { 1 1 1 } vmax + swap viewport-dim { 1 1 1 } vmax + v/ { 1 1 1 } vmin ; ! A slider scrolls a viewport. ! The offset slot is the y co-ordinate of the mouse relative to ! the thumb when it was clicked. -TUPLE: slider viewport thumb ; +TUPLE: slider viewport thumb vector ; -: hand-y ( gadget -- y ) - #! Vertical offset of hand from gadget. - hand swap relative shape-y ; +: >thumb ( pos slider -- pos ) + slider-viewport visible-portion v* ; -: slider-drag ( slider -- y ) - hand-y hand hand-click-rel shape-y + ; +: >viewport ( pos slider -- pos ) + slider-viewport visible-portion v/ ; -: slider-motion ( thumb -- ) - dup slider-drag over shape-h / - over slider-viewport scroll-viewport - relayout ; +: slider-drag ( slider -- pos ) + hand swap relative hand hand-click-rel v+ ; + +: slider-motion ( slider -- ) + dup slider-drag over >viewport + over slider-viewport scroll relayout ; : thumb-actions ( thumb -- ) dup [ drop ] [ button-down 1 ] set-action @@ -64,52 +77,60 @@ TUPLE: slider viewport thumb ; : add-thumb ( thumb slider -- ) 2dup add-gadget set-slider-thumb ; -: slider-size 16 ; +: slider-current ( slider -- pos ) + dup slider-viewport viewport-origin + dup rot slider-vector v* v- ; + +: slider-pos ( slider -- pos ) + hand over relative over slider-vector v* swap >viewport ; : slider-click ( slider -- ) - [ dup hand-y swap shape-h / ] keep - [ slider-viewport scroll-viewport ] keep - relayout ; + dup slider-pos over slider-current v+ + swap slider-viewport scroll ; : slider-actions ( slider -- ) [ slider-click ] [ button-down 1 ] set-action ; -C: slider ( viewport -- slider ) +C: slider ( viewport vector -- slider ) + [ set-slider-vector ] keep [ set-slider-viewport ] keep - [ f line-border swap set-delegate ] keep - [ swap add-thumb ] keep - [ slider-actions ] keep ; + f line-border over set-delegate + over add-thumb + dup slider-actions ; -: visible-portion ( viewport -- rational ) - #! Visible portion, between 0 and 1. - [ shape-h ] keep viewport-h 1 max / 1 min ; +: ( viewport -- slider ) { 1 0 0 } ; -: >thumb ( slider y -- y ) - #! Convert a y co-ordinate in the viewport to a thumb - #! position. - swap slider-viewport visible-portion * >fixnum ; +: ( viewport -- slider ) { 0 1 0 } ; -: thumb-height ( slider -- h ) - dup shape-h [ >thumb slider-size max ] keep min ; +: thumb-loc ( slider -- loc ) + dup slider-viewport viewport-origin vneg swap >thumb ; -: thumb-y ( slider -- y ) - dup slider-viewport viewport-y neg >thumb ; +: slider-dim { 16 16 16 } ; -M: slider pref-size drop slider-size dup ; +: thumb-dim ( slider -- h ) + [ shape-dim dup ] keep >thumb slider-dim vmax vmin ; + +M: slider pref-size drop slider-dim 3unseq drop ; M: slider layout* ( slider -- ) - dup shape-w over thumb-height pick slider-thumb resize-gadget - 0 over thumb-y rot slider-thumb move-gadget ; + dup thumb-loc over slider-vector v* + over slider-thumb set-gadget-loc + dup thumb-dim over slider-vector v* slider-dim vmax + swap slider-thumb set-gadget-dim ; -TUPLE: scroller viewport slider ; +TUPLE: scroller viewport x y ; : add-viewport 2dup set-scroller-viewport add-center ; -: add-slider 2dup set-scroller-slider add-right ; + +: add-x-slider 2dup set-scroller-x add-bottom ; + +: add-y-slider 2dup set-scroller-y add-right ; : viewport>bottom -1 swap scroll-viewport ; + : (scroll>bottom) ( scroller -- ) dup scroller-viewport viewport>bottom - scroller-slider relayout ; + dup scroller-x relayout scroller-y relayout ; : scroll>bottom ( gadget -- ) [ scroll>bottom ] swap handle-gesture drop ; @@ -121,5 +142,6 @@ C: scroller ( gadget -- scroller ) #! Wrap a scrolling pane around the gadget. over set-delegate [ >r r> add-viewport ] keep - [ dup scroller-viewport swap add-slider ] keep + dup scroller-viewport over add-x-slider + dup scroller-viewport over add-y-slider dup scroller-actions ; diff --git a/library/ui/shapes.factor b/library/ui/shapes.factor index 1dc54779da..84e4897087 100644 --- a/library/ui/shapes.factor +++ b/library/ui/shapes.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: gadgets -USING: generic kernel lists math namespaces sdl ; +USING: generic kernel lists math namespaces sdl sequences +vectors ; ! Shape protocol. Shapes are immutable; moving or resizing a ! shape makes a new shape. @@ -21,8 +22,15 @@ GENERIC: shape-w GENERIC: shape-h GENERIC: move-shape ( x y shape -- ) + +: 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. @@ -55,3 +63,9 @@ GENERIC: draw-shape ( obj -- ) : shape-size ( shape -- w h ) dup shape-w swap shape-h ; + +: shape-dim ( shape -- dim ) + dup shape-w swap shape-h 0 3vector ; + +: shape-loc ( shape -- loc ) + dup shape-x swap shape-y 0 3vector ; diff --git a/library/ui/tiles.factor b/library/ui/tiles.factor index 6cbb455729..ce7a31e85f 100644 --- a/library/ui/tiles.factor +++ b/library/ui/tiles.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: gadgets -USING: generic kernel math namespaces ; +USING: generic kernel math matrices namespaces ; ! A tile is a gadget with a caption. Dragging the caption ! moves the gadget. The title bar also has buttons for @@ -9,18 +9,18 @@ USING: generic kernel math namespaces ; TUPLE: tile original ; : click-rel ( gadget -- point ) - screen-pos - hand [ hand-clicked screen-pos - ] keep hand-click-rel - ; + screen-loc + hand [ hand-clicked screen-loc v- ] keep hand-click-rel v- ; : move-tile ( tile -- ) - dup click-rel hand screen-pos + >rect rot move-gadget ; + dup click-rel hand screen-loc v+ swap set-gadget-loc ; : start-resizing ( tile -- ) - dup shape-size rect> swap set-tile-original ; + dup shape-dim swap set-tile-original ; : resize-tile ( tile -- ) - dup screen-pos hand hand-click-pos - over tile-original + - over hand relative + >rect rot resize-gadget ; + dup screen-loc hand hand-click-loc v- over tile-original v+ + over hand relative v+ swap set-gadget-dim ; : raise ( gadget -- ) dup gadget-parent >r dup unparent r> add-gadget ;