-USING: kernel namespaces math math.constants math.functions math.order
- arrays sequences
- opengl opengl.gl opengl.glu ui ui.render ui.gadgets
- ui.gadgets.cartesian colors accessors
- processing.shapes ;
+USING: accessors arrays colors kernel math math.constants
+math.functions math.order namespaces opengl.gl processing.shapes
+sequences ui ui.gadgets.cartesian ;
IN: golden-section
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! omega(i) = 2*pi*i*(phi-1)
-
-! x(i) = 0.5*i*cos(omega(i))
-! y(i) = 0.5*i*sin(omega(i))
-
-! radius(i) = 10*sin((pi*i)/720)
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
: omega ( i -- omega ) phi 1 - * 2 * pi * ;
: x ( i -- x ) [ omega cos ] [ 0.5 * ] bi * ;
: golden-section ( -- ) 720 <iota> [ dot ] each ;
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
: <golden-section> ( -- gadget )
- <cartesian>
- { 600 600 } >>pdim
- { -400 400 } x-range
- { -400 400 } y-range
- [ golden-section ] >>action ;
-
-: golden-section-window ( -- )
- [ <golden-section> "Golden Section" open-window ] with-ui ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-MAIN: golden-section-window
+ <cartesian>
+ { 600 600 } >>pdim
+ { -400 400 } x-range
+ { -400 400 } y-range
+ [ golden-section ] >>action ;
+
+MAIN-WINDOW: golden-section-window
+ { { title "Golden Section" } }
+ <golden-section> >>gadgets ;
w-3* DEFINES 3${W}*
w-4* DEFINES 4${W}*
WHERE
-MACRO: w-n ( int -- quot ) dup '[ [ _ narray <collection> ] dip [ _ firstn ] prepend W ] ;
+MACRO: w-n ( int -- quot )
+ dup '[ [ _ narray <collection> ] dip [ _ firstn ] prepend W ] ;
: w-2 ( a b quot -- mapped ) 2 w-n ; inline
: w-3 ( a b c quot -- mapped ) 3 w-n ; inline
: w-4 ( a b c d quot -- mapped ) 4 w-n ; inline
-MACRO: w-n* ( int -- quot ) dup '[ [ _ narray <collection> #1 ] dip [ _ firstn ] prepend W ] ;
+MACRO: w-n* ( int -- quot )
+ dup '[ [ _ narray <collection> #1 ] dip [ _ firstn ] prepend W ] ;
: w-2* ( a b quot -- mapped ) 2 w-n* ; inline
: w-3* ( a b c quot -- mapped ) 3 w-n* ; inline
: w-4* ( a b c d quot -- mapped ) 4 w-n* ; inline
TUPLE: persistent id ;
-: add-types ( table -- table' ) [ dup array? [ [ first dup >upper ] [ second ] bi 3array ]
- [ dup >upper FACTOR-BLOB 3array ] if
+: add-types ( table -- table' )
+ [
+ dup array? [
+ [ first dup >upper ] [ second ] bi 3array
+ ] [
+ dup >upper FACTOR-BLOB 3array
+ ] if
] map { "id" "ID" +db-assigned-id+ } prefix ;
-: remove-types ( table -- table' ) [ dup array? [ first ] when ] map ;
+: remove-types ( table -- table' )
+ [ dup array? [ first ] when ] map ;
-SYNTAX: STORED-TUPLE: parse-tuple-definition [ drop persistent ] dip [ remove-types define-tuple-class ]
- [ nip [ dup name>> >upper ] [ add-types ] bi* define-persistent ] 3bi ;
+SYNTAX: STORED-TUPLE:
+ parse-tuple-definition [ drop persistent ] dip
+ [ remove-types define-tuple-class ]
+ [ nip [ dup name>> >upper ] [ add-types ] bi* define-persistent ] 3bi ;
-: define-db ( database class -- ) swap [ [ ensure-table ] with-db ] [ "database" set-word-prop ] 2bi ;
+: define-db ( database class -- )
+ swap [ [ ensure-table ] with-db ] [ "database" set-word-prop ] 2bi ;
+
+: query>tuple ( tuple/query -- tuple )
+ dup query? [ tuple>> ] when ;
+
+: w/db ( query quot -- )
+ [ dup query>tuple class-of "database" word-prop ] dip with-db ; inline
-: query>tuple ( tuple/query -- tuple ) dup query? [ tuple>> ] when ;
-: w/db ( query quot -- ) [ dup query>tuple class-of "database" word-prop ] dip with-db ; inline
: get-tuples ( query -- tuples ) [ select-tuples ] w/db ;
: get-tuple ( query -- tuple ) [ select-tuple ] w/db ;
: store-tuple ( tuple -- ) [ insert-tuple ] w/db ;
: modify-tuple ( tuple -- ) [ update-tuple ] w/db ;
: remove-tuples ( tuple -- ) [ delete-tuples ] w/db ;
-TUPLE: pattern value ; C: <pattern> pattern
+TUPLE: pattern value ;
+C: <pattern> pattern
SYNTAX: %" parse-string <pattern> suffix! ;
M: pattern where value>> over column-name>> 0% " LIKE " 0% bind# ;
-USING: accessors fonts generalizations io.styles kernel locals
-macros models models.combinators monads sequences
-sequences.generalizations ui ui.gadgets ui.gadgets.buttons
-ui.gadgets.controls ui.gadgets.editors ui.gadgets.labels
+USING: accessors fonts kernel models.combinators monads
+sequences sequences.generalizations ui ui.gadgets
+ui.gadgets.buttons ui.gadgets.controls ui.gadgets.labels
ui.gadgets.layout ui.gadgets.packs wrap.strings ;
IN: ui.gadgets.alerts
-:: alert ( quot string -- ) <pile> { 10 10 } >>gap 1 >>align
- string 22 wrap-lines <label> T{ font { name "sans-serif" } { size 18 } } >>font { 200 100 } >>pref-dim add-gadget
- "okay" [ close-window ] quot append <border-button> add-gadget "" open-window ;
+
+:: alert ( quot string -- )
+ <pile> { 10 10 } >>gap 1 >>align
+ string 22 wrap-lines <label> sans-serif-font 18 >>size >>font
+ { 200 100 } >>pref-dim add-gadget
+ "okay" [ close-window ] quot append
+ <border-button> add-gadget "" open-window ;
: alert* ( str -- ) [ ] swap alert ;
:: ask-user ( string -- model' )
[
- string <label> T{ font { name "sans-serif" } { size 14 } } >>font dup , :> lbl
+ string <label> sans-serif-font 14 >>size >>font dup , :> lbl
<model-field*> ->% 1 :> fldm
"okay" <model-border-btn> :> btn
btn -> [ fldm swap updates ]
[ [ drop lbl close-window ] $> , ] bi
] <vbox> { 161 86 } >>pref-dim "" open-window ;
-MACRO: ask-buttons ( buttons -- quot ) dup length [
- [ swap
- [ 22 wrap-lines <label> T{ font { name "sans-serif" } { size 18 } } >>font ,
- [ [ <model-border-btn> [ close-window ] >>hook -> ] map ] <hbox> , ] <vbox>
- "" open-window
- ] dip firstn
+MACRO: ask-buttons ( buttons -- quot )
+ dup length [
+ [
+ swap [
+ 22 wrap-lines <label> sans-serif-font 18 >>size >>font ,
+ [ [ <model-border-btn> [ close-window ] >>hook -> ] map ] <hbox> ,
+ ] <vbox> "" open-window
+ ] dip firstn
] 2curry ;
projects / factor.git / commitdiff