: next-logical? ( op linear -- ? )
dup car next-logical dup [ car class = ] [ 2drop f ] ifte ;
-: reduce ( linear op new -- linear ? )
+: collapse ( linear op new -- linear ? )
>r over cdr next-logical? [
dup car vop-label
r> execute swap cdr cons t
M: %call simplify-node ( linear vop -- ? )
#! Tail call optimization.
- drop \ %return \ %jump reduce ;
+ drop \ %return \ %jump collapse ;
M: %call-label simplify-node ( linear vop -- ? )
#! Tail call optimization.
- drop \ %return \ %jump-label reduce ;
+ drop \ %return \ %jump-label collapse ;
: double-jump ( linear op2 op1 -- linear ? )
#! A jump to a jump is just a jump. If the next logical node
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: gadgets
-USING: generic kernel matrices sequences ;
+USING: generic kernel lists matrices namespaces sequences ;
TUPLE: divider splitter ;
-C: divider ( splitter -- divider )
- [ set-divider-splitter ] keep
+C: divider ( -- divider )
<plain-gadget> over set-delegate
dup t reverse-video set-paint-prop ;
-M: divider pref-size drop 16 16 ;
+: divider-size { 8 8 0 } ;
-TUPLE: splitter vector first divider second split ;
+M: divider pref-size drop divider-size 3unseq drop ;
+
+TUPLE: splitter vector split ;
M: splitter orientation splitter-vector ;
C: splitter ( first second vector -- splitter )
<empty-gadget> over set-delegate
[ set-splitter-vector ] keep
- [ set-splitter-second ] keep
- [ set-splitter-first ] keep
- [ dup <divider> swap set-splitter-divider ] keep
+ swapd
+ [ add-gadget ] keep
+ <divider> over add-gadget
+ [ add-gadget ] keep
1/2 over set-splitter-split ;
-: <x-splitter> ( first second -- splitter )
- { 1 0 0 } <splitter> ;
-
-: <y-splitter> ( first second -- splitter )
- { 0 1 0 } <splitter> ;
+: <x-splitter> { 1 0 0 } <splitter> ;
-: splitter-pref-dims ( splitter -- dim dim dim )
- dup splitter-first pref-dim
- over splitter-divider pref-dim
- rot splitter-second pref-dim ;
+: <y-splitter> { 0 1 0 } <splitter> ;
-M: splitter pref-size ( splitter -- w h )
- [ splitter-pref-dims 3dup vmax vmax >r v+ v+ r> ] keep
- orient 3unseq drop ;
+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 ;
-: size-divider ( splitter -- )
- dup shape-dim over splitter-divider
- [ rot orient ] keep set-gadget-dim ;
+: splitter-part ( splitter -- vec )
+ dup splitter-split swap shape-dim n*v divider-size 1/2 v*n v- ;
-: move-divider ( splitter -- )
+: splitter-layout ( splitter -- [ a b c ] )
[
- dup shape-dim dup pick splitter-split v*n { 8 8 8 } v-
- rot orient
- ] keep splitter-divider set-gadget-loc ;
+ dup splitter-part ,
+ divider-size ,
+ dup shape-dim swap splitter-part v- ,
+ ] make-list ;
-: layout-divider ( splitter -- )
- dup size-divider move-divider ;
+: layout-divider ( assoc -- )
+ [ uncons set-gadget-dim ] each ;
M: splitter layout* ( splitter -- )
- ( layout-divider ) drop ;
+ [
+ dup splitter-layout [ nip ( { 0 0 0 } rot orient ) ] map-with
+ ] keep gadget-children zip layout-divider ;