[ "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 ] [ ] ] ]
: 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
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 ;
: 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 ;
[ { 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
! 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
#! 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 [
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 ;
! 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
! - 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
: 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 ;
! 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 -- )
#! 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 [
! 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> = ;
: 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 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 )
[ <empty-gadget> 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 ;
+
+: >thumb ( pos slider -- pos )
+ slider-viewport visible-portion v* ;
-: hand-y ( gadget -- y )
- #! Vertical offset of hand from gadget.
- hand swap relative shape-y ;
+: >viewport ( pos slider -- pos )
+ slider-viewport visible-portion v/ ;
-: slider-drag ( slider -- y )
- hand-y hand hand-click-rel shape-y + ;
+: slider-drag ( slider -- pos )
+ hand swap relative hand hand-click-rel v+ ;
-: slider-motion ( thumb -- )
- dup slider-drag over shape-h /
- 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
: 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
- [ <thumb> swap add-thumb ] keep
- [ slider-actions ] keep ;
+ f line-border over set-delegate
+ <thumb> over add-thumb
+ dup slider-actions ;
+
+: <x-slider> ( viewport -- slider ) { 1 0 0 } <slider> ;
-: visible-portion ( viewport -- rational )
- #! Visible portion, between 0 and 1.
- [ shape-h ] keep viewport-h 1 max / 1 min ;
+: <y-slider> ( viewport -- slider ) { 0 1 0 } <slider> ;
-: >thumb ( slider y -- y )
- #! Convert a y co-ordinate in the viewport to a thumb
- #! position.
- swap slider-viewport visible-portion * >fixnum ;
+: thumb-loc ( slider -- loc )
+ dup slider-viewport viewport-origin vneg swap >thumb ;
-: thumb-height ( slider -- h )
- dup shape-h [ >thumb slider-size max ] keep min ;
+: slider-dim { 16 16 16 } ;
-: thumb-y ( slider -- y )
- dup slider-viewport viewport-y neg >thumb ;
+: thumb-dim ( slider -- h )
+ [ shape-dim dup ] keep >thumb slider-dim vmax vmin ;
-M: slider pref-size drop slider-size dup ;
+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 ;
#! 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 ;
! 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.
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.
: 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 ;
! 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
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 ;
projects / factor.git / commitdiff