make-frame/track now compiles (except that add-gadget doesn't; this is pending)

slava 2006-07-28 20:07:22 +00:00
parent 12ad53b6ae
commit 66c26e234a
5 changed files with 30 additions and 21 deletions

View File

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

View File

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

View File

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

View File

@ -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* ;

View File

@ -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 ;