make-frame/track now compiles (except that add-gadget doesn't; this is pending)
parent
12ad53b6ae
commit
66c26e234a
|
@ -38,7 +38,7 @@ M: frame layout* ( frame -- dim )
|
||||||
] with-grid ;
|
] with-grid ;
|
||||||
|
|
||||||
: make-frame ( specs -- gadget )
|
: make-frame ( specs -- gadget )
|
||||||
<frame> [ swap build-grid ] keep ;
|
<frame> [ swap build-grid ] keep ; inline
|
||||||
|
|
||||||
: make-frame* ( gadget specs -- gadget )
|
: make-frame* ( gadget specs -- gadget )
|
||||||
over [ delegate>frame build-grid ] keep ;
|
over [ delegate>frame build-grid ] keep ; inline
|
||||||
|
|
|
@ -72,4 +72,4 @@ M: grid layout* ( frame -- dim )
|
||||||
#! Specs is an array of quadruples { quot post setter loc }.
|
#! Specs is an array of quadruples { quot post setter loc }.
|
||||||
#! The setter has stack effect ( new gadget -- ),
|
#! The setter has stack effect ( new gadget -- ),
|
||||||
#! the loc is @center, @top, etc.
|
#! the loc is @center, @top, etc.
|
||||||
swap [ [ [ grid-add ] add-spec ] each ] with-gadget ;
|
swap [ [ grid-add ] build-spec ] with-gadget ; inline
|
||||||
|
|
|
@ -135,13 +135,12 @@ C: divider ( -- divider )
|
||||||
#! Specs is an array of quadruples { quot post setter loc }.
|
#! Specs is an array of quadruples { quot post setter loc }.
|
||||||
#! The setter has stack effect ( new gadget -- ),
|
#! The setter has stack effect ( new gadget -- ),
|
||||||
#! the loc is a ratio from 0 to 1.
|
#! the loc is a ratio from 0 to 1.
|
||||||
swap [
|
2dup
|
||||||
[ [ [ drop track-add ] add-spec ] each ] keep
|
swap [ [ drop track-add ] build-spec ] with-gadget
|
||||||
[ peek ] map gadget get set-track-sizes
|
[ peek ] map swap set-track-sizes ; inline
|
||||||
] with-gadget ;
|
|
||||||
|
|
||||||
: make-track ( specs orientation -- gadget )
|
: make-track ( specs orientation -- gadget )
|
||||||
<track> [ swap build-track ] keep ;
|
<track> [ swap build-track ] keep ; inline
|
||||||
|
|
||||||
: make-track* ( gadget specs orientation -- gadget )
|
: make-track* ( gadget specs orientation -- gadget )
|
||||||
<track> pick [ set-delegate build-track ] keep ;
|
<track> pick [ set-delegate build-track ] keep ; inline
|
||||||
|
|
|
@ -1,8 +1,8 @@
|
||||||
! Copyright (C) 2005, 2006 Slava Pestov.
|
! Copyright (C) 2005, 2006 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
IN: gadgets
|
IN: gadgets
|
||||||
USING: generic hashtables kernel math namespaces sequences
|
USING: generic hashtables inference kernel math namespaces
|
||||||
vectors words ;
|
sequences vectors words ;
|
||||||
|
|
||||||
GENERIC: graft* ( gadget -- )
|
GENERIC: graft* ( gadget -- )
|
||||||
|
|
||||||
|
@ -61,15 +61,25 @@ M: gadget ungraft* drop ;
|
||||||
#! Add all gadgets in a sequence to a parent gadget.
|
#! Add all gadgets in a sequence to a parent gadget.
|
||||||
swap [ over (add-gadget) ] each relayout ;
|
swap [ over (add-gadget) ] each relayout ;
|
||||||
|
|
||||||
: add-spec ( { quot setter post loc } quot -- )
|
: add-spec ( quot { quot setter post loc } -- )
|
||||||
[
|
dup first %
|
||||||
over first %
|
dup second [ [ dup gadget get ] % , ] when*
|
||||||
over second [ [ dup gadget get ] % , ] when*
|
dup third %
|
||||||
over third %
|
|
||||||
[ gadget get ] %
|
[ gadget get ] %
|
||||||
swap fourth ,
|
fourth ,
|
||||||
%
|
% ;
|
||||||
] [ ] make call ;
|
|
||||||
|
: (build-spec) ( quot spec -- quot )
|
||||||
|
[ [ add-spec ] each-with ] [ ] make ;
|
||||||
|
|
||||||
|
: build-spec ( spec quot -- )
|
||||||
|
swap (build-spec) call ;
|
||||||
|
|
||||||
|
\ build-spec { 2 0 } "infer-effect" set-word-prop
|
||||||
|
|
||||||
|
\ build-spec [
|
||||||
|
pop-literal pop-literal nip (build-spec) infer-quot-value
|
||||||
|
] "infer" set-word-prop
|
||||||
|
|
||||||
: (parents) ( gadget -- )
|
: (parents) ( gadget -- )
|
||||||
[ dup , gadget-parent (parents) ] when* ;
|
[ dup , gadget-parent (parents) ] when* ;
|
||||||
|
|
|
@ -124,7 +124,7 @@ M: compose model-changed ( compose -- )
|
||||||
swap delegate set-model ;
|
swap delegate set-model ;
|
||||||
|
|
||||||
M: compose set-model ( value compose -- )
|
M: compose set-model ( value compose -- )
|
||||||
model-dependencies [ set-model ] 2map ;
|
model-dependencies [ set-model ] 2each ;
|
||||||
|
|
||||||
TUPLE: history back forward ;
|
TUPLE: history back forward ;
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue