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

@@ -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 ] [ ] ] ]

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
 

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 <vector>
+    [ >r rot r> push ] keep
+    [ swapd push ] keep
+    [ push ] keep ;

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 ;

library/test/sequences.factor

@@ -12,3 +12,5 @@ USING: lists sequences test vectors ;
 [ { 3 4 } ] [ 2 4 1 10 <range> subseq ] unit-test
 [ { 3 4 } ] [ 0 2 2 4 1 10 <range> <slice> subseq ] unit-test
 [ "cba" ] [ 3 "abcdef" head-slice reverse ] unit-test
+
+[ 1 2 3 ] [ 1 2 3 3vector 3unseq ] unit-test

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
+USING: generic hashtables kernel lists math namespaces sequences
-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 -- )
+: set-gadget-loc ( loc gadget -- )
-    >r 3dup shape-pos >r rect> r> = [
+    2dup shape-loc =
-        3drop
+    [ 2drop ] [ [ set-shape-loc ] keep redraw ] ifte ;
-    ] r> ifte ; inline
 
 : move-gadget ( x y gadget -- )
-    [ [ move-shape ] keep redraw ] ?move ;
+    >r 0 3vector r> set-gadget-loc ;
 
-: ?resize ( w h gadget quot -- )
+: set-gadget-dim ( dim gadget -- )
-    >r 3dup shape-size rect> >r rect> r> = [
+    2dup shape-dim =
-        3drop
+    [ 2drop ] [ [ set-shape-dim ] keep relayout* ] ifte ;
-    ] r> ifte ; inline
 
 : 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 ;

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
+USING: alien generic io kernel lists math namespaces prettyprint
-sequences sdl io ;
+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 )
     <empty-gadget>
     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 ;
 

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 [

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 ;

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 )
+: viewport-dim ( viewport -- h ) gadget-child pref-dim ;
-    #! Make sure we don't scroll above the first line, or beyond
+
-    #! the end of the document.
+: fix-scroll ( origin viewport -- origin )
-    dup shape-h swap viewport-h - max 0 min ;
+    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
+    [ viewport-x swap 0 3vector ] keep 
-    [ set-viewport-y ] keep
+    scroll ;
-    relayout ;
 
 C: viewport ( content -- viewport )
     [ <empty-gadget> swap set-delegate ] keep
     [ add-gadget ] keep
-    0 over set-viewport-x
+    { 0 0 0 } over set-viewport-origin ;
-    0 over set-viewport-y ;
 
 M: viewport pref-size gadget-child pref-size ;
 
 M: viewport layout* ( viewport -- )
-    dup gadget-child dup prefer
+    dup viewport-origin
-    >r dup viewport-x swap viewport-y r> move-gadget ;
+    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 )
+: >thumb ( pos slider -- pos )
-    #! Vertical offset of hand from gadget.
+    slider-viewport visible-portion v* ;
-    hand swap relative shape-y ;
 
-: slider-drag ( slider -- y )
+: >viewport ( pos slider -- pos )
-    hand-y hand hand-click-rel shape-y + ;
+    slider-viewport visible-portion v/ ;
 
-: slider-motion ( thumb -- )
+: slider-drag ( slider -- pos )
-    dup slider-drag over shape-h /
+    hand swap relative hand hand-click-rel v+ ;
-    over slider-viewport scroll-viewport
+
-    relayout ;
+: 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
+    dup slider-pos over slider-current v+
-    [ slider-viewport scroll-viewport ] keep
+    swap slider-viewport scroll ;
-    relayout ;
 
 : 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
+    f line-border over set-delegate
-    [ <thumb> swap add-thumb ] keep
+    <thumb> over add-thumb
-    [ slider-actions ] keep ;
+    dup slider-actions ;
 
-: visible-portion ( viewport -- rational )
+: <x-slider> ( viewport -- slider ) { 1 0 0 } <slider> ;
-    #! Visible portion, between 0 and 1.
-    [ shape-h ] keep viewport-h 1 max / 1 min ;
 
-: >thumb ( slider y -- y )
+: <y-slider> ( viewport -- slider ) { 0 1 0 } <slider> ;
-    #! Convert a y co-ordinate in the viewport to a thumb
-    #! position.
-    swap slider-viewport visible-portion * >fixnum ;
 
-: thumb-height ( slider -- h )
+: thumb-loc ( slider -- loc )
-    dup shape-h [ >thumb slider-size max ] keep min ;
+    dup slider-viewport viewport-origin vneg swap >thumb ;
 
-: thumb-y ( slider -- y )
+: slider-dim { 16 16 16 } ;
-    dup slider-viewport viewport-y neg >thumb ;
 
-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
+    dup thumb-loc over slider-vector v*
-    0 over thumb-y rot slider-thumb move-gadget ;
+    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.
     <frame> over set-delegate
     [ >r <viewport> r> add-viewport ] keep
-    [ dup scroller-viewport <slider> swap add-slider ] keep
+    dup scroller-viewport <x-slider> over add-x-slider
+    dup scroller-viewport <y-slider> over add-y-slider
     dup scroller-actions ;

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 ;

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
+    screen-loc
-    hand [ hand-clicked screen-pos - ] keep hand-click-rel - ;
+    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 +
+    dup screen-loc hand hand-click-loc v- over tile-original v+
-    over hand relative + >rect rot resize-gadget ;
+    over hand relative v+ swap set-gadget-dim ;
  
 : raise ( gadget -- )
     dup gadget-parent >r dup unparent r> add-gadget ;