2dup contains? [ nip ] [ cons ] ifte ;
M: general-list reverse ( list -- list )
- [ ] swap [ swons ] each ;
+ [ ] [ swons ] reduce ;
M: f map ( list quot -- list ) drop ;
: each-with ( obj seq quot -- | quot: obj elt -- )
swap [ with ] each 2drop ; inline
+: reduce ( list identity quot -- value | quot: x y -- z )
+ swapd each ; inline
+
G: tree-each ( obj quot -- | quot: elt -- )
[ over ] [ type ] ; inline
: map-with ( obj list quot -- list | quot: obj elt -- elt )
swap [ with rot ] map 2nip ; inline
+: accumulate ( list identity quot -- values | quot: x y -- z )
+ rot [ pick >r swap call r> ] map-with nip ; inline
+
G: 2map ( seq seq quot -- seq | quot: elt elt -- elt )
[ over ] [ type ] ; inline
: vmin ( v v -- v ) [ min ] 2map ;
: vneg ( v -- v ) [ neg ] map ;
-: sum ( v -- n ) 0 swap [ + ] each ;
-: product 1 swap [ * ] each ;
+: sum ( v -- n ) 0 [ + ] reduce ;
+: product 1 [ * ] 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 ;
[ set-rect-y ] keep
[ set-rect-x ] keep ;
-: black [ 0 0 0 ] ;
-: gray [ 128 128 128 ] ;
-: white [ 255 255 255 ] ;
-: red [ 255 0 0 ] ;
-: green [ 0 255 0 ] ;
-: blue [ 0 0 255 ] ;
-
: with-pixels ( quot -- )
width get [
height get [
dup empty? [
not-a-number
] [
- 0 swap [ digit> pick digit+ ] each nip
+ 0 [ digit> pick digit+ ] reduce nip
] ifte ;
: base> ( str base -- num )
IN: temporary
-USING: lists sequences test vectors ;
+USING: lists math sequences test vectors ;
[ [ 1 2 3 4 ] ] [ 1 5 <range> >list ] unit-test
[ 3 ] [ 1 4 <range> length ] unit-test
[ "cba" ] [ 3 "abcdef" head-slice reverse ] unit-test
[ 1 2 3 ] [ 1 2 3 3vector 3unseq ] unit-test
+
+[ 5040 ] [ [ 1 2 3 4 5 6 7 ] 1 [ * ] reduce ] unit-test
+
+[ [ 1 1 2 6 24 120 720 ] ]
+[ [ 1 2 3 4 5 6 7 ] 1 [ * ] accumilate ] unit-test
--- /dev/null
+IN: gadgets
+
+: black [ 0 0 0 ] ;
+: gray [ 128 128 128 ] ;
+: white [ 255 255 255 ] ;
+: red [ 255 0 0 ] ;
+: green [ 0 255 0 ] ;
+: blue [ 0 0 255 ] ;
GENERIC: user-input* ( ch gadget -- ? )
M: gadget user-input* 2drop t ;
-
-GENERIC: orientation ( gadget -- vector )
-
-: orient* ( x y axis -- v )
- 2dup v* >r >r drop dup r> v* v- r> v+ ;
-
-: orient ( x y gadget -- vec )
- orientation orient* ;
}} world get set-gadget-paint
1024 768 world get resize-gadget
+
+ <plain-gadget> world get add-gadget
+
+ <console> "Stack display goes here" <label> <y-splitter>
+ 3/4 over set-splitter-split
+ world get add-gadget
] bind
! A pane is an area that can display text.
! output: pile
-! current: label
+! current: shelf
! input: editor
-TUPLE: pane output current input continuation ;
+TUPLE: pane output active current input continuation ;
: add-output 2dup set-pane-output add-gadget ;
: add-input 2dup set-pane-input add-gadget ;
-: <active-line> ( current input -- line )
- <line-shelf> [ tuck add-gadget add-gadget ] keep ;
+: <active-line> ( input current -- line )
+ <line-shelf> [ add-gadget ] keep [ add-gadget ] keep ;
+
+: init-active-line ( pane -- )
+ dup pane-active [ unparent ] when*
+ [ dup pane-input swap pane-current <active-line> ] keep
+ 2dup set-pane-active add-gadget ;
: pane-paint ( pane -- )
[[ "Monospaced" 12 ]] font set-paint-prop ;
C: pane ( -- pane )
<line-pile> over set-delegate
<line-pile> over add-output
- "" <label> dup pick set-pane-current >r
- "" <editor> dup pick set-pane-input r>
- <active-line> over add-gadget
+ "" <label> over set-pane-current
+ "" <editor> over set-pane-input
+ dup init-active-line
dup pane-paint
dup pane-actions ;
-: add-line ( text pane -- )
- >r <label> r> pane-output add-gadget ;
-
: pane-write-1 ( text pane -- )
- pane-current dup label-text rot append over set-label-text
- relayout ;
+ >r <label> r> pane-current add-gadget ;
: pane-terpri ( pane -- )
- dup pane-current dup label-text rot add-line
- "" over set-label-text relayout ;
+ dup pane-current over pane-output add-gadget
+ <line-shelf> over set-pane-current init-active-line ;
: pane-write ( pane list -- )
2dup car swap pane-write-1
M: pane stream-close ( stream -- ) drop ;
: <console> ( -- pane )
- <pane> dup [
- [ clear print-banner listener ] in-thread
- ] with-stream ;
+ <pane> dup
+ [ [ clear print-banner listener ] in-thread ] with-stream
+ <scroller> ;
: console ( -- )
#! Open an UI console window.
- <console> <scroller> "Listener" <tile> world get [
+ <console> "Listener" <tile> world get [
shape-size rect> 3/4 * >rect rot resize-gadget
] 2keep add-gadget ;
: <thumb> ( -- thumb )
<plain-gadget>
- dup t reverse-video set-paint-prop
+ dup gray background set-paint-prop
dup thumb-actions ;
: add-thumb ( thumb slider -- )
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: gadgets
-USING: generic kernel lists matrices namespaces sequences ;
+USING: generic kernel lists math matrices namespaces sequences ;
TUPLE: divider splitter ;
-C: divider ( -- divider )
- <plain-gadget> over set-delegate
- dup t reverse-video set-paint-prop ;
-
: divider-size { 8 8 0 } ;
M: divider pref-size drop divider-size 3unseq drop ;
TUPLE: splitter vector split ;
-M: splitter orientation splitter-vector ;
+: hand>split ( splitter -- n )
+ hand relative hand hand-click-rel v- divider-size 1/2 v*n v+ ;
+
+: divider-motion ( splitter -- )
+ dup hand>split
+ over shape-dim { 1 1 1 } vmax v/ over splitter-vector v.
+ 0 max 1 min over set-splitter-split relayout ;
+
+: divider-actions ( thumb -- )
+ dup [ drop ] [ button-down 1 ] set-action
+ dup [ drop ] [ button-up 1 ] set-action
+ [ gadget-parent divider-motion ] [ drag 1 ] set-action ;
+
+C: divider ( -- divider )
+ <plain-gadget> over set-delegate
+ dup t reverse-video set-paint-prop
+ dup divider-actions ;
C: splitter ( first second vector -- splitter )
<empty-gadget> over set-delegate
[ add-gadget ] keep
1/2 over set-splitter-split ;
-: <x-splitter> { 1 0 0 } <splitter> ;
+: <x-splitter> { 0 1 0 } <splitter> ;
-: <y-splitter> { 0 1 0 } <splitter> ;
+: <y-splitter> { 1 0 0 } <splitter> ;
M: splitter pref-size
[
gadget-children [ pref-dim ] map
- dup { 0 0 0 } swap [ vmax ] each
- swap { 0 0 0 } swap [ v+ ] each
- ] keep orient 3unseq drop ;
+ dup { 0 0 0 } [ vmax ] reduce
+ swap { 0 0 0 } [ v+ ] reduce
+ ] keep splitter-vector set-axis 3unseq drop ;
: splitter-part ( splitter -- vec )
dup splitter-split swap shape-dim n*v divider-size 1/2 v*n v- ;
dup shape-dim swap splitter-part v- ,
] make-list ;
+: packed-locs ( axis sizes gadget -- )
+ >r
+ { 0 0 0 } [ v+ ] accumulate
+ [ { 0 0 0 } swap rot set-axis ] map-with
+ r> gadget-children zip [ uncons set-gadget-loc ] each ;
+
+: packed-dims ( axis sizes gadget -- dims )
+ [
+ shape-dim swap [ >r 2dup r> rot set-axis ] map 2nip
+ ] keep gadget-children zip [ uncons set-gadget-dim ] each ;
+
: layout-divider ( assoc -- )
[ uncons set-gadget-dim ] each ;
+: packed-layout ( axis sizes gadgets -- )
+ 3dup packed-locs packed-dims ;
+
M: splitter layout* ( splitter -- )
- [
- dup splitter-layout [ nip ( { 0 0 0 } rot orient ) ] map-with
- ] keep gadget-children zip layout-divider ;
+ dup splitter-vector over splitter-layout rot packed-layout ;
[[ "Exit" [ f world get set-world-running? ] ]]
] root-menu set
-world get [ drop show-root-menu ] [ button-down 1 ] set-action
+! world get [ drop show-root-menu ] [ button-down 1 ] set-action
! open at any one time.
TUPLE: world running? hand menu ;
-: <world-box> ( -- box )
- <plain-gadget> ;
-
C: world ( -- world )
- <world-box> over set-delegate
+ f <stack> over set-delegate
t over set-world-running?
dup <hand> over set-world-hand ;