steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorcode.org/git/factor into wordtimer

db4
Phil Dawes 2008-07-11 08:52:05 +01:00
parent e3ce229c1f 62b1ebb33d
commit 8a35d21084
86 changed files with 1369 additions and 1281 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
extra/color-picker/color-picker.factor
View File

@ -11,10 +11,10 @@ IN: color-picker
: <color-slider> ( model -- gadget ) : <color-slider> ( model -- gadget )
<x-slider> 1 over set-slider-line ; <x-slider> 1 over set-slider-line ;
TUPLE: color-preview ; TUPLE: color-preview < gadget ;
: <color-preview> ( model -- gadget ) : <color-preview> ( model -- gadget )
<gadget> color-preview construct-control color-preview new-gadget
{ 100 100 } over set-rect-dim ; { 100 100 } over set-rect-dim ;
M: color-preview model-changed M: color-preview model-changed

724
extra/cpu/8080/emulator/emulator.factor
View File

@ -2,9 +2,9 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
! !
USING: accessors kernel math sequences words arrays io io.files USING: accessors kernel math sequences words arrays io io.files
namespaces math.parser assocs quotations parser lexer math.parser assocs quotations parser lexer
parser-combinators tools.time io.encodings.binary sequences.deep peg peg.ebnf peg.parsers tools.time io.encodings.binary sequences.deep
symbols combinators ; symbols combinators fry namespaces ;
IN: cpu.8080.emulator IN: cpu.8080.emulator
TUPLE: cpu b c d e f h l a pc sp halted? last-interrupt cycles ram ; TUPLE: cpu b c d e f h l a pc sp halted? last-interrupt cycles ram ;
@ -748,24 +748,15 @@ SYMBOLS: $1 $2 $3 $4 ;
#! is the getter word for that register with stack effect #! is the getter word for that register with stack effect
#! ( cpu -- value ). The second item is the setter word with #! ( cpu -- value ). The second item is the setter word with
#! stack effect ( value cpu -- ). #! stack effect ( value cpu -- ).
"A" token <EBNF
"B" token <|> main=("A" | "B" | "C" | "D" | "E" | "H" | "L") => [[ register-lookup ]]
"C" token <|> EBNF> ;
"D" token <|>
"E" token <|>
"H" token <|>
"L" token <|> [ register-lookup ] <@ ;
: all-flags ( -- parser ) : all-flags ( -- parser )
#! A parser for 16-bit flags. #! A parser for 16-bit flags.
"NZ" token <EBNF
"NC" token <|> main=("NZ" | "NC" | "PO" | "PE" | "Z" | "C" | "P" | "M") => [[ flag-lookup ]]
"PO" token <|> EBNF> ;
"PE" token <|>
"Z" token <|>
"C" token <|>
"P" token <|>
"M" token <|> [ flag-lookup ] <@ ;
: 16-bit-registers ( -- parser ) : 16-bit-registers ( -- parser )
#! A parser for 16-bit registers. On a successfull parse the #! A parser for 16-bit registers. On a successfull parse the
@ -773,23 +764,21 @@ SYMBOLS: $1 $2 $3 $4 ;
#! is the getter word for that register with stack effect #! is the getter word for that register with stack effect
#! ( cpu -- value ). The second item is the setter word with #! ( cpu -- value ). The second item is the setter word with
#! stack effect ( value cpu -- ). #! stack effect ( value cpu -- ).
"AF" token <EBNF
"BC" token <|> main=("AF" | "BC" | "DE" | "HL" | "SP") => [[ register-lookup ]]
"DE" token <|> EBNF> ;
"HL" token <|>
"SP" token <|> [ register-lookup ] <@ ;
: all-registers ( -- parser ) : all-registers ( -- parser )
#! Return a parser that can parse the format #! Return a parser that can parse the format
#! for 8 bit or 16 bit registers. #! for 8 bit or 16 bit registers.
8-bit-registers 16-bit-registers <|> ; [ 16-bit-registers , 8-bit-registers , ] choice* ;
: indirect ( parser -- parser ) : indirect ( parser -- parser )
#! Given a parser, return a parser which parses the original #! Given a parser, return a parser which parses the original
#! wrapped in brackets, representing an indirect reference. #! wrapped in brackets, representing an indirect reference.
#! eg. BC -> (BC). The value of the original parser is left in #! eg. BC -> (BC). The value of the original parser is left in
#! the parse tree. #! the parse tree.
"(" token swap &> ")" token <& ; "(" ")" surrounded-by ;
: generate-instruction ( vector string -- quot ) : generate-instruction ( vector string -- quot )
#! Generate the quotation for an instruction, given the instruction in #! Generate the quotation for an instruction, given the instruction in
@ -800,89 +789,112 @@ SYMBOLS: $1 $2 $3 $4 ;
#! Return a parser for then instruction identified by the token. #! Return a parser for then instruction identified by the token.
#! The parser return parses the token only and expects no additional #! The parser return parses the token only and expects no additional
#! arguments to the instruction. #! arguments to the instruction.
token [ [ { } clone , , \ generate-instruction , ] [ ] make ] <@ ; token [ '[ { } , generate-instruction ] ] action ;
: complex-instruction ( type token -- parser ) : complex-instruction ( type token -- parser )
#! Return a parser for an instruction identified by the token. #! Return a parser for an instruction identified by the token.
#! The instruction is expected to take additional arguments by #! The instruction is expected to take additional arguments by
#! being combined with other parsers. Then 'type' is used for a lookup #! being combined with other parsers. Then 'type' is used for a lookup
#! in a pattern hashtable to return the instruction quotation pattern. #! in a pattern hashtable to return the instruction quotation pattern.
token swap [ nip [ , \ generate-instruction , ] [ ] make ] curry <@ ; token swap [ nip '[ , generate-instruction ] ] curry action ;
: no-params ( ast -- ast )
first { } swap curry ;
: one-param ( ast -- ast )
first2 swap curry ;
: two-params ( ast -- ast )
first3 append swap curry ;
: NOP-instruction ( -- parser ) : NOP-instruction ( -- parser )
"NOP" simple-instruction ; "NOP" simple-instruction ;
: RET-NN-instruction ( -- parser ) : RET-NN-instruction ( -- parser )
"RET-NN" "RET" complex-instruction [
"nn" token sp <& "RET-NN" "RET" complex-instruction ,
just [ { } clone swap curry ] <@ ; "nn" token sp hide ,
] seq* [ no-params ] action ;
: RST-0-instruction ( -- parser ) : RST-0-instruction ( -- parser )
"RST-0" "RST" complex-instruction [
"0" token sp <& "RST-0" "RST" complex-instruction ,
just [ { } clone swap curry ] <@ ; "0" token sp hide ,
] seq* [ no-params ] action ;
: RST-8-instruction ( -- parser ) : RST-8-instruction ( -- parser )
"RST-8" "RST" complex-instruction [
"8" token sp <& "RST-8" "RST" complex-instruction ,
just [ { } clone swap curry ] <@ ; "8" token sp hide ,
] seq* [ no-params ] action ;
: RST-10H-instruction ( -- parser ) : RST-10H-instruction ( -- parser )
"RST-10H" "RST" complex-instruction [
"10H" token sp <& "RST-10H" "RST" complex-instruction ,
just [ { } clone swap curry ] <@ ; "10H" token sp hide ,
] seq* [ no-params ] action ;
: RST-18H-instruction ( -- parser ) : RST-18H-instruction ( -- parser )
"RST-18H" "RST" complex-instruction [
"18H" token sp <& "RST-18H" "RST" complex-instruction ,
just [ { } clone swap curry ] <@ ; "18H" token sp hide ,
] seq* [ no-params ] action ;
: RST-20H-instruction ( -- parser ) : RST-20H-instruction ( -- parser )
"RST-20H" "RST" complex-instruction [
"20H" token sp <& "RST-20H" "RST" complex-instruction ,
just [ { } clone swap curry ] <@ ; "20H" token sp hide ,
] seq* [ no-params ] action ;
: RST-28H-instruction ( -- parser ) : RST-28H-instruction ( -- parser )
"RST-28H" "RST" complex-instruction [
"28H" token sp <& "RST-28H" "RST" complex-instruction ,
just [ { } clone swap curry ] <@ ; "28H" token sp hide ,
] seq* [ no-params ] action ;
: RST-30H-instruction ( -- parser ) : RST-30H-instruction ( -- parser )
"RST-30H" "RST" complex-instruction [
"30H" token sp <& "RST-30H" "RST" complex-instruction ,
just [ { } clone swap curry ] <@ ; "30H" token sp hide ,
] seq* [ no-params ] action ;
: RST-38H-instruction ( -- parser ) : RST-38H-instruction ( -- parser )
"RST-38H" "RST" complex-instruction [
"38H" token sp <& "RST-38H" "RST" complex-instruction ,
just [ { } clone swap curry ] <@ ; "38H" token sp hide ,
] seq* [ no-params ] action ;
: JP-NN-instruction ( -- parser ) : JP-NN-instruction ( -- parser )
"JP-NN" "JP" complex-instruction [
"nn" token sp <& "JP-NN" "JP" complex-instruction ,
just [ { } clone swap curry ] <@ ; "nn" token sp hide ,
] seq* [ no-params ] action ;
: JP-F|FF,NN-instruction ( -- parser ) : JP-F|FF,NN-instruction ( -- parser )
"JP-F|FF,NN" "JP" complex-instruction [
all-flags sp <&> "JP-F|FF,NN" "JP" complex-instruction ,
",nn" token <& all-flags sp ,
just [ first2 swap curry ] <@ ; ",nn" token hide ,
] seq* [ one-param ] action ;
: JP-(RR)-instruction ( -- parser ) : JP-(RR)-instruction ( -- parser )
"JP-(RR)" "JP" complex-instruction [
16-bit-registers indirect sp <&> "JP-(RR)" "JP" complex-instruction ,
just [ first2 swap curry ] <@ ; 16-bit-registers indirect sp ,
] seq* [ one-param ] action ;
: CALL-NN-instruction ( -- parser ) : CALL-NN-instruction ( -- parser )
"CALL-NN" "CALL" complex-instruction [
"nn" token sp <& "CALL-NN" "CALL" complex-instruction ,
just [ { } clone swap curry ] <@ ; "nn" token sp hide ,
] seq* [ no-params ] action ;
: CALL-F|FF,NN-instruction ( -- parser ) : CALL-F|FF,NN-instruction ( -- parser )
"CALL-F|FF,NN" "CALL" complex-instruction [
all-flags sp <&> "CALL-F|FF,NN" "CALL" complex-instruction ,
",nn" token <& all-flags sp ,
just [ first2 swap curry ] <@ ; ",nn" token hide ,
] seq* [ one-param ] action ;
: RLCA-instruction ( -- parser ) : RLCA-instruction ( -- parser )
"RLCA" simple-instruction ; "RLCA" simple-instruction ;
@ -918,364 +930,430 @@ SYMBOLS: $1 $2 $3 $4 ;
"RRA" simple-instruction ; "RRA" simple-instruction ;
: DEC-R-instruction ( -- parser ) : DEC-R-instruction ( -- parser )
"DEC-R" "DEC" complex-instruction 8-bit-registers sp <&> [
just [ first2 swap curry ] <@ ; "DEC-R" "DEC" complex-instruction ,
8-bit-registers sp ,
] seq* [ one-param ] action ;
: DEC-RR-instruction ( -- parser ) : DEC-RR-instruction ( -- parser )
"DEC-RR" "DEC" complex-instruction 16-bit-registers sp <&> [
just [ first2 swap curry ] <@ ; "DEC-RR" "DEC" complex-instruction ,
16-bit-registers sp ,
] seq* [ one-param ] action ;
: DEC-(RR)-instruction ( -- parser ) : DEC-(RR)-instruction ( -- parser )
"DEC-(RR)" "DEC" complex-instruction [
16-bit-registers indirect sp <&> "DEC-(RR)" "DEC" complex-instruction ,
just [ first2 swap curry ] <@ ; 16-bit-registers indirect sp ,
] seq* [ one-param ] action ;
: POP-RR-instruction ( -- parser ) : POP-RR-instruction ( -- parser )
"POP-RR" "POP" complex-instruction all-registers sp <&> [
just [ first2 swap curry ] <@ ; "POP-RR" "POP" complex-instruction ,
all-registers sp ,
] seq* [ one-param ] action ;
: PUSH-RR-instruction ( -- parser ) : PUSH-RR-instruction ( -- parser )
"PUSH-RR" "PUSH" complex-instruction all-registers sp <&> [
just [ first2 swap curry ] <@ ; "PUSH-RR" "PUSH" complex-instruction ,
all-registers sp ,
] seq* [ one-param ] action ;
: INC-R-instruction ( -- parser ) : INC-R-instruction ( -- parser )
"INC-R" "INC" complex-instruction 8-bit-registers sp <&> [
just [ first2 swap curry ] <@ ; "INC-R" "INC" complex-instruction ,
8-bit-registers sp ,
] seq* [ one-param ] action ;
: INC-RR-instruction ( -- parser ) : INC-RR-instruction ( -- parser )
"INC-RR" "INC" complex-instruction 16-bit-registers sp <&> [
just [ first2 swap curry ] <@ ; "INC-RR" "INC" complex-instruction ,
16-bit-registers sp ,
] seq* [ one-param ] action ;
: INC-(RR)-instruction ( -- parser ) : INC-(RR)-instruction ( -- parser )
"INC-(RR)" "INC" complex-instruction [
all-registers indirect sp <&> just [ first2 swap curry ] <@ ; "INC-(RR)" "INC" complex-instruction ,
all-registers indirect sp ,
] seq* [ one-param ] action ;
: RET-F|FF-instruction ( -- parser ) : RET-F|FF-instruction ( -- parser )
"RET-F|FF" "RET" complex-instruction all-flags sp <&> [
just [ first2 swap curry ] <@ ; "RET-F|FF" "RET" complex-instruction ,
all-flags sp ,
] seq* [ one-param ] action ;
: AND-N-instruction ( -- parser ) : AND-N-instruction ( -- parser )
"AND-N" "AND" complex-instruction [
"n" token sp <& "AND-N" "AND" complex-instruction ,
just [ { } clone swap curry ] <@ ; "n" token sp hide ,
] seq* [ no-params ] action ;
: AND-R-instruction ( -- parser ) : AND-R-instruction ( -- parser )
"AND-R" "AND" complex-instruction [
8-bit-registers sp <&> just [ first2 swap curry ] <@ ; "AND-R" "AND" complex-instruction ,
8-bit-registers sp ,
] seq* [ one-param ] action ;
: AND-(RR)-instruction ( -- parser ) : AND-(RR)-instruction ( -- parser )
"AND-(RR)" "AND" complex-instruction [
16-bit-registers indirect sp <&> just [ first2 swap curry ] <@ ; "AND-(RR)" "AND" complex-instruction ,
16-bit-registers indirect sp ,
] seq* [ one-param ] action ;
: XOR-N-instruction ( -- parser ) : XOR-N-instruction ( -- parser )
"XOR-N" "XOR" complex-instruction [
"n" token sp <& "XOR-N" "XOR" complex-instruction ,
just [ { } clone swap curry ] <@ ; "n" token sp hide ,
] seq* [ no-params ] action ;
: XOR-R-instruction ( -- parser ) : XOR-R-instruction ( -- parser )
"XOR-R" "XOR" complex-instruction [
8-bit-registers sp <&> just [ first2 swap curry ] <@ ; "XOR-R" "XOR" complex-instruction ,
8-bit-registers sp ,
] seq* [ one-param ] action ;
: XOR-(RR)-instruction ( -- parser ) : XOR-(RR)-instruction ( -- parser )
"XOR-(RR)" "XOR" complex-instruction [
16-bit-registers indirect sp <&> just [ first2 swap curry ] <@ ; "XOR-(RR)" "XOR" complex-instruction ,
16-bit-registers indirect sp ,
] seq* [ one-param ] action ;
: OR-N-instruction ( -- parser ) : OR-N-instruction ( -- parser )
"OR-N" "OR" complex-instruction [
"n" token sp <& "OR-N" "OR" complex-instruction ,
just [ { } clone swap curry ] <@ ; "n" token sp hide ,
] seq* [ no-params ] action ;
: OR-R-instruction ( -- parser ) : OR-R-instruction ( -- parser )
"OR-R" "OR" complex-instruction [
8-bit-registers sp <&> just [ first2 swap curry ] <@ ; "OR-R" "OR" complex-instruction ,
8-bit-registers sp ,
] seq* [ one-param ] action ;
: OR-(RR)-instruction ( -- parser ) : OR-(RR)-instruction ( -- parser )
"OR-(RR)" "OR" complex-instruction [
16-bit-registers indirect sp <&> just [ first2 swap curry ] <@ ; "OR-(RR)" "OR" complex-instruction ,
16-bit-registers indirect sp ,
] seq* [ one-param ] action ;
: CP-N-instruction ( -- parser ) : CP-N-instruction ( -- parser )
"CP-N" "CP" complex-instruction [
"n" token sp <& "CP-N" "CP" complex-instruction ,
just [ { } clone swap curry ] <@ ; "n" token sp hide ,
] seq* [ no-params ] action ;
: CP-R-instruction ( -- parser ) : CP-R-instruction ( -- parser )
"CP-R" "CP" complex-instruction [
8-bit-registers sp <&> just [ first2 swap curry ] <@ ; "CP-R" "CP" complex-instruction ,
8-bit-registers sp ,
] seq* [ one-param ] action ;
: CP-(RR)-instruction ( -- parser ) : CP-(RR)-instruction ( -- parser )
"CP-(RR)" "CP" complex-instruction [
16-bit-registers indirect sp <&> just [ first2 swap curry ] <@ ; "CP-(RR)" "CP" complex-instruction ,
16-bit-registers indirect sp ,
] seq* [ one-param ] action ;
: ADC-R,N-instruction ( -- parser ) : ADC-R,N-instruction ( -- parser )
"ADC-R,N" "ADC" complex-instruction [
8-bit-registers sp <&> "ADC-R,N" "ADC" complex-instruction ,
",n" token <& 8-bit-registers sp ,
just [ first2 swap curry ] <@ ; ",n" token hide ,
] seq* [ one-param ] action ;
: ADC-R,R-instruction ( -- parser ) : ADC-R,R-instruction ( -- parser )
"ADC-R,R" "ADC" complex-instruction [
8-bit-registers sp <&> "ADC-R,R" "ADC" complex-instruction ,
"," token <& 8-bit-registers sp ,
8-bit-registers <&> "," token hide ,
just [ first2 swap first2 swap >r prepend r> curry ] <@ ; 8-bit-registers ,
] seq* [ two-params ] action ;
: ADC-R,(RR)-instruction ( -- parser ) : ADC-R,(RR)-instruction ( -- parser )
"ADC-R,(RR)" "ADC" complex-instruction [
8-bit-registers sp <&> "ADC-R,(RR)" "ADC" complex-instruction ,
"," token <& 8-bit-registers sp ,
16-bit-registers indirect <&> "," token hide ,
just [ first2 swap first2 swap >r prepend r> curry ] <@ ; 16-bit-registers indirect ,
] seq* [ two-params ] action ;
: SBC-R,N-instruction ( -- parser ) : SBC-R,N-instruction ( -- parser )
"SBC-R,N" "SBC" complex-instruction [
8-bit-registers sp <&> "SBC-R,N" "SBC" complex-instruction ,
",n" token <& 8-bit-registers sp ,
just [ first2 swap curry ] <@ ; ",n" token hide ,
] seq* [ one-param ] action ;
: SBC-R,R-instruction ( -- parser ) : SBC-R,R-instruction ( -- parser )
"SBC-R,R" "SBC" complex-instruction [
8-bit-registers sp <&> "SBC-R,R" "SBC" complex-instruction ,
"," token <& 8-bit-registers sp ,
8-bit-registers <&> "," token hide ,
just [ first2 swap first2 swap >r prepend r> curry ] <@ ; 8-bit-registers ,
] seq* [ two-params ] action ;
: SBC-R,(RR)-instruction ( -- parser ) : SBC-R,(RR)-instruction ( -- parser )
"SBC-R,(RR)" "SBC" complex-instruction [
8-bit-registers sp <&> "SBC-R,(RR)" "SBC" complex-instruction ,
"," token <& 8-bit-registers sp ,
16-bit-registers indirect <&> "," token hide ,
just [ first2 swap first2 swap >r prepend r> curry ] <@ ; 16-bit-registers indirect ,
] seq* [ two-params ] action ;
: SUB-R-instruction ( -- parser ) : SUB-R-instruction ( -- parser )
"SUB-R" "SUB" complex-instruction [
8-bit-registers sp <&> "SUB-R" "SUB" complex-instruction ,
just [ first2 swap curry ] <@ ; 8-bit-registers sp ,
] seq* [ one-param ] action ;
: SUB-(RR)-instruction ( -- parser ) : SUB-(RR)-instruction ( -- parser )
"SUB-(RR)" "SUB" complex-instruction [
16-bit-registers indirect sp <&> "SUB-(RR)" "SUB" complex-instruction ,
just [ first2 swap curry ] <@ ; 16-bit-registers indirect sp ,
] seq* [ one-param ] action ;
: SUB-N-instruction ( -- parser ) : SUB-N-instruction ( -- parser )
"SUB-N" "SUB" complex-instruction [
"n" token sp <& "SUB-N" "SUB" complex-instruction ,
just [ { } clone swap curry ] <@ ; "n" token sp hide ,
] seq* [ no-params ] action ;
: ADD-R,N-instruction ( -- parser ) : ADD-R,N-instruction ( -- parser )
"ADD-R,N" "ADD" complex-instruction [
8-bit-registers sp <&> "ADD-R,N" "ADD" complex-instruction ,
",n" token <& 8-bit-registers sp ,
just [ first2 swap curry ] <@ ; ",n" token hide ,
] seq* [ one-param ] action ;
: ADD-R,R-instruction ( -- parser ) : ADD-R,R-instruction ( -- parser )
"ADD-R,R" "ADD" complex-instruction [
8-bit-registers sp <&> "ADD-R,R" "ADD" complex-instruction ,
"," token <& 8-bit-registers sp ,
8-bit-registers <&> "," token hide ,
just [ first2 swap first2 swap >r prepend r> curry ] <@ ; 8-bit-registers ,
] seq* [ two-params ] action ;
: ADD-RR,RR-instruction ( -- parser ) : ADD-RR,RR-instruction ( -- parser )
"ADD-RR,RR" "ADD" complex-instruction [
16-bit-registers sp <&> "ADD-RR,RR" "ADD" complex-instruction ,
"," token <& 16-bit-registers sp ,
16-bit-registers <&> "," token hide ,
just [ first2 swap first2 swap >r prepend r> curry ] <@ ; 16-bit-registers ,
] seq* [ two-params ] action ;
: ADD-R,(RR)-instruction ( -- parser ) : ADD-R,(RR)-instruction ( -- parser )
"ADD-R,(RR)" "ADD" complex-instruction [
8-bit-registers sp <&> "ADD-R,(RR)" "ADD" complex-instruction ,
"," token <& 8-bit-registers sp ,
16-bit-registers indirect <&> "," token hide ,
just [ first2 swap first2 swap >r prepend r> curry ] <@ ; 16-bit-registers indirect ,
] seq* [ two-params ] action ;
: LD-RR,NN-instruction ( -- parser ) : LD-RR,NN-instruction ( -- parser )
#! LD BC,nn #! LD BC,nn
"LD-RR,NN" "LD" complex-instruction [
16-bit-registers sp <&> "LD-RR,NN" "LD" complex-instruction ,
",nn" token <& 16-bit-registers sp ,
just [ first2 swap curry ] <@ ; ",nn" token hide ,
] seq* [ one-param ] action ;
: LD-R,N-instruction ( -- parser ) : LD-R,N-instruction ( -- parser )
#! LD B,n #! LD B,n
"LD-R,N" "LD" complex-instruction [
8-bit-registers sp <&> "LD-R,N" "LD" complex-instruction ,
",n" token <& 8-bit-registers sp ,
just [ first2 swap curry ] <@ ; ",n" token hide ,
] seq* [ one-param ] action ;
: LD-(RR),N-instruction ( -- parser ) : LD-(RR),N-instruction ( -- parser )
"LD-(RR),N" "LD" complex-instruction [
16-bit-registers indirect sp <&> "LD-(RR),N" "LD" complex-instruction ,
",n" token <& 16-bit-registers indirect sp ,
just [ first2 swap curry ] <@ ; ",n" token hide ,
] seq* [ one-param ] action ;
: LD-(RR),R-instruction ( -- parser ) : LD-(RR),R-instruction ( -- parser )
#! LD (BC),A #! LD (BC),A
"LD-(RR),R" "LD" complex-instruction [
16-bit-registers indirect sp <&> "LD-(RR),R" "LD" complex-instruction ,
"," token <& 16-bit-registers indirect sp ,
8-bit-registers <&> "," token hide ,
just [ first2 swap first2 swap >r prepend r> curry ] <@ ; 8-bit-registers ,
] seq* [ two-params ] action ;
: LD-R,R-instruction ( -- parser ) : LD-R,R-instruction ( -- parser )
"LD-R,R" "LD" complex-instruction [
8-bit-registers sp <&> "LD-R,R" "LD" complex-instruction ,
"," token <& 8-bit-registers sp ,
8-bit-registers <&> "," token hide ,
just [ first2 swap first2 swap >r prepend r> curry ] <@ ; 8-bit-registers ,
] seq* [ two-params ] action ;
: LD-RR,RR-instruction ( -- parser ) : LD-RR,RR-instruction ( -- parser )
"LD-RR,RR" "LD" complex-instruction [
16-bit-registers sp <&> "LD-RR,RR" "LD" complex-instruction ,
"," token <& 16-bit-registers sp ,
16-bit-registers <&> "," token hide ,
just [ first2 swap first2 swap >r prepend r> curry ] <@ ; 16-bit-registers ,
] seq* [ two-params ] action ;
: LD-R,(RR)-instruction ( -- parser ) : LD-R,(RR)-instruction ( -- parser )
"LD-R,(RR)" "LD" complex-instruction [
8-bit-registers sp <&> "LD-R,(RR)" "LD" complex-instruction ,
"," token <& 8-bit-registers sp ,
16-bit-registers indirect <&> "," token hide ,
just [ first2 swap first2 swap >r prepend r> curry ] <@ ; 16-bit-registers indirect ,
] seq* [ two-params ] action ;
: LD-(NN),RR-instruction ( -- parser ) : LD-(NN),RR-instruction ( -- parser )
"LD-(NN),RR" "LD" complex-instruction [
"nn" token indirect sp <& "LD-(NN),RR" "LD" complex-instruction ,
"," token <& "nn" token indirect sp hide ,
16-bit-registers <&> "," token hide ,
just [ first2 swap curry ] <@ ; 16-bit-registers ,
] seq* [ one-param ] action ;
: LD-(NN),R-instruction ( -- parser ) : LD-(NN),R-instruction ( -- parser )
"LD-(NN),R" "LD" complex-instruction [
"nn" token indirect sp <& "LD-(NN),R" "LD" complex-instruction ,
"," token <& "nn" token indirect sp hide ,
8-bit-registers <&> "," token hide ,
just [ first2 swap curry ] <@ ; 8-bit-registers ,
] seq* [ one-param ] action ;
: LD-RR,(NN)-instruction ( -- parser ) : LD-RR,(NN)-instruction ( -- parser )
"LD-RR,(NN)" "LD" complex-instruction [
16-bit-registers sp <&> "LD-RR,(NN)" "LD" complex-instruction ,
"," token <& 16-bit-registers sp ,
"nn" token indirect <& "," token hide ,
just [ first2 swap curry ] <@ ; "nn" token indirect hide ,
] seq* [ one-param ] action ;
: LD-R,(NN)-instruction ( -- parser ) : LD-R,(NN)-instruction ( -- parser )
"LD-R,(NN)" "LD" complex-instruction [
8-bit-registers sp <&> "LD-R,(NN)" "LD" complex-instruction ,
"," token <& 8-bit-registers sp ,
"nn" token indirect <& "," token hide ,
just [ first2 swap curry ] <@ ; "nn" token indirect hide ,
] seq* [ one-param ] action ;
: OUT-(N),R-instruction ( -- parser ) : OUT-(N),R-instruction ( -- parser )
"OUT-(N),R" "OUT" complex-instruction [
"n" token indirect sp <& "OUT-(N),R" "OUT" complex-instruction ,
"," token <& "n" token indirect sp hide ,
8-bit-registers <&> "," token hide ,
just [ first2 swap curry ] <@ ; 8-bit-registers ,
] seq* [ one-param ] action ;
: IN-R,(N)-instruction ( -- parser ) : IN-R,(N)-instruction ( -- parser )
"IN-R,(N)" "IN" complex-instruction [
8-bit-registers sp <&> "IN-R,(N)" "IN" complex-instruction ,
"," token <& 8-bit-registers sp ,
"n" token indirect <& "," token hide ,
just [ first2 swap curry ] <@ ; "n" token indirect hide ,
] seq* [ one-param ] action ;
: EX-(RR),RR-instruction ( -- parser ) : EX-(RR),RR-instruction ( -- parser )
"EX-(RR),RR" "EX" complex-instruction [
16-bit-registers indirect sp <&> "EX-(RR),RR" "EX" complex-instruction ,
"," token <& 16-bit-registers indirect sp ,
16-bit-registers <&> "," token hide ,
just [ first2 swap first2 swap >r prepend r> curry ] <@ ; 16-bit-registers ,
] seq* [ two-params ] action ;
: EX-RR,RR-instruction ( -- parser ) : EX-RR,RR-instruction ( -- parser )
"EX-RR,RR" "EX" complex-instruction [
16-bit-registers sp <&> "EX-RR,RR" "EX" complex-instruction ,
"," token <& 16-bit-registers sp ,
16-bit-registers <&> "," token hide ,
just [ first2 swap first2 swap >r prepend r> curry ] <@ ; 16-bit-registers ,
] seq* [ two-params ] action ;
: 8080-generator-parser ( -- parser ) : 8080-generator-parser ( -- parser )
NOP-instruction [
RST-0-instruction <|> NOP-instruction ,
RST-8-instruction <|> RST-0-instruction ,
RST-10H-instruction <|> RST-8-instruction ,
RST-18H-instruction <|> RST-10H-instruction ,
RST-20H-instruction <|> RST-18H-instruction ,
RST-28H-instruction <|> RST-20H-instruction ,
RST-30H-instruction <|> RST-28H-instruction ,
RST-38H-instruction <|> RST-30H-instruction ,
JP-F|FF,NN-instruction <|> RST-38H-instruction ,
JP-NN-instruction <|> JP-F|FF,NN-instruction ,
JP-(RR)-instruction <|> JP-NN-instruction ,
CALL-F|FF,NN-instruction <|> JP-(RR)-instruction ,
CALL-NN-instruction <|> CALL-F|FF,NN-instruction ,
CPL-instruction <|> CALL-NN-instruction ,
CCF-instruction <|> CPL-instruction ,
SCF-instruction <|> CCF-instruction ,
DAA-instruction <|> SCF-instruction ,
RLA-instruction <|> DAA-instruction ,
RRA-instruction <|> RLA-instruction ,
RLCA-instruction <|> RRA-instruction ,
RRCA-instruction <|> RLCA-instruction ,
HALT-instruction <|> RRCA-instruction ,
DI-instruction <|> HALT-instruction ,
EI-instruction <|> DI-instruction ,
AND-N-instruction <|> EI-instruction ,
AND-R-instruction <|> AND-N-instruction ,
AND-(RR)-instruction <|> AND-R-instruction ,
XOR-N-instruction <|> AND-(RR)-instruction ,
XOR-R-instruction <|> XOR-N-instruction ,
XOR-(RR)-instruction <|> XOR-R-instruction ,
OR-N-instruction <|> XOR-(RR)-instruction ,
OR-R-instruction <|> OR-N-instruction ,
OR-(RR)-instruction <|> OR-R-instruction ,
CP-N-instruction <|> OR-(RR)-instruction ,
CP-R-instruction <|> CP-N-instruction ,
CP-(RR)-instruction <|> CP-R-instruction ,
DEC-RR-instruction <|> CP-(RR)-instruction ,
DEC-R-instruction <|> DEC-RR-instruction ,
DEC-(RR)-instruction <|> DEC-R-instruction ,
POP-RR-instruction <|> DEC-(RR)-instruction ,
PUSH-RR-instruction <|> POP-RR-instruction ,
INC-RR-instruction <|> PUSH-RR-instruction ,
INC-R-instruction <|> INC-RR-instruction ,
INC-(RR)-instruction <|> INC-R-instruction ,
LD-RR,NN-instruction <|> INC-(RR)-instruction ,
LD-R,N-instruction <|> LD-RR,NN-instruction ,
LD-R,R-instruction <|> LD-RR,RR-instruction ,
LD-RR,RR-instruction <|> LD-R,N-instruction ,
LD-(RR),N-instruction <|> LD-R,R-instruction ,
LD-(RR),R-instruction <|> LD-(RR),N-instruction ,
LD-R,(RR)-instruction <|> LD-(RR),R-instruction ,
LD-(NN),RR-instruction <|> LD-R,(RR)-instruction ,
LD-(NN),R-instruction <|> LD-(NN),RR-instruction ,
LD-RR,(NN)-instruction <|> LD-(NN),R-instruction ,
LD-R,(NN)-instruction <|> LD-RR,(NN)-instruction ,
ADC-R,N-instruction <|> LD-R,(NN)-instruction ,
ADC-R,R-instruction <|> ADC-R,(RR)-instruction ,
ADC-R,(RR)-instruction <|> ADC-R,N-instruction ,
ADD-R,N-instruction <|> ADC-R,R-instruction ,
ADD-R,R-instruction <|> ADD-R,N-instruction ,
ADD-RR,RR-instruction <|> ADD-R,(RR)-instruction ,
ADD-R,(RR)-instruction <|> ADD-R,R-instruction ,
SBC-R,N-instruction <|> ADD-RR,RR-instruction ,
SBC-R,R-instruction <|> SBC-R,N-instruction ,
SBC-R,(RR)-instruction <|> SBC-R,R-instruction ,
SUB-R-instruction <|> SBC-R,(RR)-instruction ,
SUB-(RR)-instruction <|> SUB-R-instruction ,
SUB-N-instruction <|> SUB-(RR)-instruction ,
RET-F|FF-instruction <|> SUB-N-instruction ,
RET-NN-instruction <|> RET-F|FF-instruction ,
OUT-(N),R-instruction <|> RET-NN-instruction ,
IN-R,(N)-instruction <|> OUT-(N),R-instruction ,
EX-(RR),RR-instruction <|> IN-R,(N)-instruction ,
EX-RR,RR-instruction <|> EX-(RR),RR-instruction ,
just ; EX-RR,RR-instruction ,
] choice* [ call ] action ;
: instruction-quotations ( string -- emulate-quot ) : instruction-quotations ( string -- emulate-quot )
#! Given an instruction string, return the emulation quotation for #! Given an instruction string, return the emulation quotation for
#! it. This will later be expanded to produce the disassembly and #! it. This will later be expanded to produce the disassembly and
#! assembly quotations. #! assembly quotations.
8080-generator-parser some parse call ; 8080-generator-parser parse ;
SYMBOL: last-instruction SYMBOL: last-instruction
SYMBOL: last-opcode SYMBOL: last-opcode

22
extra/fjsc/fjsc-tests.factor
View File

@ -4,31 +4,31 @@ USING: kernel tools.test peg fjsc ;
IN: fjsc.tests IN: fjsc.tests
{ T{ ast-expression f V{ T{ ast-number f 55 } T{ ast-identifier f "2abc1" } T{ ast-number f 100 } } } } [ { T{ ast-expression f V{ T{ ast-number f 55 } T{ ast-identifier f "2abc1" } T{ ast-number f 100 } } } } [
"55 2abc1 100" 'expression' parse parse-result-ast "55 2abc1 100" 'expression' parse
] unit-test ] unit-test
{ T{ ast-quotation f V{ T{ ast-number f 55 } T{ ast-identifier f "2abc1" } T{ ast-number f 100 } } } } [ { T{ ast-quotation f V{ T{ ast-number f 55 } T{ ast-identifier f "2abc1" } T{ ast-number f 100 } } } } [
"[ 55 2abc1 100 ]" 'quotation' parse parse-result-ast "[ 55 2abc1 100 ]" 'quotation' parse
] unit-test ] unit-test
{ T{ ast-array f V{ T{ ast-number f 55 } T{ ast-identifier f "2abc1" } T{ ast-number f 100 } } } } [ { T{ ast-array f V{ T{ ast-number f 55 } T{ ast-identifier f "2abc1" } T{ ast-number f 100 } } } } [
"{ 55 2abc1 100 }" 'array' parse parse-result-ast "{ 55 2abc1 100 }" 'array' parse
] unit-test ] unit-test
{ T{ ast-stack-effect f V{ } V{ "d" "e" "f" } } } [ { T{ ast-stack-effect f V{ } V{ "d" "e" "f" } } } [
"( -- d e f )" 'stack-effect' parse parse-result-ast "( -- d e f )" 'stack-effect' parse
] unit-test ] unit-test
{ T{ ast-stack-effect f V{ "a" "b" "c" } V{ "d" "e" "f" } } } [ { T{ ast-stack-effect f V{ "a" "b" "c" } V{ "d" "e" "f" } } } [
"( a b c -- d e f )" 'stack-effect' parse parse-result-ast "( a b c -- d e f )" 'stack-effect' parse
] unit-test ] unit-test
{ T{ ast-stack-effect f V{ "a" "b" "c" } V{ } } } [ { T{ ast-stack-effect f V{ "a" "b" "c" } V{ } } } [
"( a b c -- )" 'stack-effect' parse parse-result-ast "( a b c -- )" 'stack-effect' parse
] unit-test ] unit-test
{ T{ ast-stack-effect f V{ } V{ } } } [ { T{ ast-stack-effect f V{ } V{ } } } [
"( -- )" 'stack-effect' parse parse-result-ast "( -- )" 'stack-effect' parse
] unit-test ] unit-test
{ f } [ { f } [
@ -37,18 +37,18 @@ IN: fjsc.tests
{ T{ ast-expression f V{ T{ ast-string f "abcd" } } } } [ { T{ ast-expression f V{ T{ ast-string f "abcd" } } } } [
"\"abcd\"" 'statement' parse parse-result-ast "\"abcd\"" 'statement' parse
] unit-test ] unit-test
{ T{ ast-expression f V{ T{ ast-use f "foo" } } } } [ { T{ ast-expression f V{ T{ ast-use f "foo" } } } } [
"USE: foo" 'statement' parse parse-result-ast "USE: foo" 'statement' parse
] unit-test ] unit-test
{ T{ ast-expression f V{ T{ ast-in f "foo" } } } } [ { T{ ast-expression f V{ T{ ast-in f "foo" } } } } [
"IN: foo" 'statement' parse parse-result-ast "IN: foo" 'statement' parse
] unit-test ] unit-test
{ T{ ast-expression f V{ T{ ast-using f V{ "foo" "bar" } } } } } [ { T{ ast-expression f V{ T{ ast-using f V{ "foo" "bar" } } } } } [
"USING: foo bar ;" 'statement' parse parse-result-ast "USING: foo bar ;" 'statement' parse
] unit-test ] unit-test

165
extra/fjsc/fjsc.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2006 Chris Double. All Rights Reserved. ! Copyright (C) 2006 Chris Double. All Rights Reserved.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel peg strings promises sequences math USING: accessors kernel peg strings sequences math
math.parser namespaces words quotations arrays hashtables io math.parser namespaces words quotations arrays hashtables io
io.streams.string assocs memoize ascii peg.parsers ; io.streams.string assocs ascii peg.parsers accessors ;
IN: fjsc IN: fjsc
TUPLE: ast-number value ; TUPLE: ast-number value ;
@ -20,28 +20,13 @@ TUPLE: ast-using names ;
TUPLE: ast-in name ; TUPLE: ast-in name ;
TUPLE: ast-hashtable elements ; TUPLE: ast-hashtable elements ;
C: <ast-number> ast-number
C: <ast-identifier> ast-identifier
C: <ast-string> ast-string
C: <ast-quotation> ast-quotation
C: <ast-array> ast-array
C: <ast-define> ast-define
C: <ast-expression> ast-expression
C: <ast-word> ast-word
C: <ast-comment> ast-comment
C: <ast-stack-effect> ast-stack-effect
C: <ast-use> ast-use
C: <ast-using> ast-using
C: <ast-in> ast-in
C: <ast-hashtable> ast-hashtable
: identifier-middle? ( ch -- bool ) : identifier-middle? ( ch -- bool )
[ blank? not ] keep [ blank? not ] keep
[ "}];\"" member? not ] keep [ "}];\"" member? not ] keep
digit? not digit? not
and and ; and and ;
MEMO: 'identifier-ends' ( -- parser ) : 'identifier-ends' ( -- parser )
[ [
[ blank? not ] keep [ blank? not ] keep
[ CHAR: " = not ] keep [ CHAR: " = not ] keep
@ -52,22 +37,22 @@ MEMO: 'identifier-ends' ( -- parser )
and and and and and and and and and and
] satisfy repeat0 ; ] satisfy repeat0 ;
MEMO: 'identifier-middle' ( -- parser ) : 'identifier-middle' ( -- parser )
[ identifier-middle? ] satisfy repeat1 ; [ identifier-middle? ] satisfy repeat1 ;
MEMO: 'identifier' ( -- parser ) : 'identifier' ( -- parser )
[ [
'identifier-ends' , 'identifier-ends' ,
'identifier-middle' , 'identifier-middle' ,
'identifier-ends' , 'identifier-ends' ,
] { } make seq [ ] seq* [
concat >string f <ast-identifier> concat >string f ast-identifier boa
] action ; ] action ;
DEFER: 'expression' DEFER: 'expression'
MEMO: 'effect-name' ( -- parser ) : 'effect-name' ( -- parser )
[ [
[ blank? not ] keep [ blank? not ] keep
[ CHAR: ) = not ] keep [ CHAR: ) = not ] keep
@ -75,98 +60,98 @@ MEMO: 'effect-name' ( -- parser )
and and and and
] satisfy repeat1 [ >string ] action ; ] satisfy repeat1 [ >string ] action ;
MEMO: 'stack-effect' ( -- parser ) : 'stack-effect' ( -- parser )
[ [
"(" token hide , "(" token hide ,
'effect-name' sp repeat0 , 'effect-name' sp repeat0 ,
"--" token sp hide , "--" token sp hide ,
'effect-name' sp repeat0 , 'effect-name' sp repeat0 ,
")" token sp hide , ")" token sp hide ,
] { } make seq [ ] seq* [
first2 <ast-stack-effect> first2 ast-stack-effect boa
] action ; ] action ;
MEMO: 'define' ( -- parser ) : 'define' ( -- parser )
[ [
":" token sp hide , ":" token sp hide ,
'identifier' sp [ ast-identifier-value ] action , 'identifier' sp [ value>> ] action ,
'stack-effect' sp optional , 'stack-effect' sp optional ,
'expression' , 'expression' ,
";" token sp hide , ";" token sp hide ,
] { } make seq [ first3 <ast-define> ] action ; ] seq* [ first3 ast-define boa ] action ;
MEMO: 'quotation' ( -- parser ) : 'quotation' ( -- parser )
[ [
"[" token sp hide , "[" token sp hide ,
'expression' [ ast-expression-values ] action , 'expression' [ values>> ] action ,
"]" token sp hide , "]" token sp hide ,
] { } make seq [ first <ast-quotation> ] action ; ] seq* [ first ast-quotation boa ] action ;
MEMO: 'array' ( -- parser ) : 'array' ( -- parser )
[ [
"{" token sp hide , "{" token sp hide ,
'expression' [ ast-expression-values ] action , 'expression' [ values>> ] action ,
"}" token sp hide , "}" token sp hide ,
] { } make seq [ first <ast-array> ] action ; ] seq* [ first ast-array boa ] action ;
MEMO: 'word' ( -- parser ) : 'word' ( -- parser )
[ [
"\\" token sp hide , "\\" token sp hide ,
'identifier' sp , 'identifier' sp ,
] { } make seq [ first ast-identifier-value f <ast-word> ] action ; ] seq* [ first value>> f ast-word boa ] action ;
MEMO: 'atom' ( -- parser ) : 'atom' ( -- parser )
[ [
'identifier' , 'identifier' ,
'integer' [ <ast-number> ] action , 'integer' [ ast-number boa ] action ,
'string' [ <ast-string> ] action , 'string' [ ast-string boa ] action ,
] { } make choice ; ] choice* ;
MEMO: 'comment' ( -- parser ) : 'comment' ( -- parser )
[ [
[ [
"#!" token sp , "#!" token sp ,
"!" token sp , "!" token sp ,
] { } make choice hide , ] choice* hide ,
[ [
dup CHAR: \n = swap CHAR: \r = or not dup CHAR: \n = swap CHAR: \r = or not
] satisfy repeat0 , ] satisfy repeat0 ,
] { } make seq [ drop <ast-comment> ] action ; ] seq* [ drop ast-comment boa ] action ;
MEMO: 'USE:' ( -- parser ) : 'USE:' ( -- parser )
[ [
"USE:" token sp hide , "USE:" token sp hide ,
'identifier' sp , 'identifier' sp ,
] { } make seq [ first ast-identifier-value <ast-use> ] action ; ] seq* [ first value>> ast-use boa ] action ;
MEMO: 'IN:' ( -- parser ) : 'IN:' ( -- parser )
[ [
"IN:" token sp hide , "IN:" token sp hide ,
'identifier' sp , 'identifier' sp ,
] { } make seq [ first ast-identifier-value <ast-in> ] action ; ] seq* [ first value>> ast-in boa ] action ;
MEMO: 'USING:' ( -- parser ) : 'USING:' ( -- parser )
[ [
"USING:" token sp hide , "USING:" token sp hide ,
'identifier' sp [ ast-identifier-value ] action repeat1 , 'identifier' sp [ value>> ] action repeat1 ,
";" token sp hide , ";" token sp hide ,
] { } make seq [ first <ast-using> ] action ; ] seq* [ first ast-using boa ] action ;
MEMO: 'hashtable' ( -- parser ) : 'hashtable' ( -- parser )
[ [
"H{" token sp hide , "H{" token sp hide ,
'expression' [ ast-expression-values ] action , 'expression' [ values>> ] action ,
"}" token sp hide , "}" token sp hide ,
] { } make seq [ first <ast-hashtable> ] action ; ] seq* [ first ast-hashtable boa ] action ;
MEMO: 'parsing-word' ( -- parser ) : 'parsing-word' ( -- parser )
[ [
'USE:' , 'USE:' ,
'USING:' , 'USING:' ,
'IN:' , 'IN:' ,
] { } make choice ; ] choice* ;
MEMO: 'expression' ( -- parser ) : 'expression' ( -- parser )
[ [
[ [
'comment' , 'comment' ,
@ -177,17 +162,17 @@ MEMO: 'expression' ( -- parser )
'hashtable' sp , 'hashtable' sp ,
'word' sp , 'word' sp ,
'atom' sp , 'atom' sp ,
] { } make choice repeat0 [ <ast-expression> ] action ] choice* repeat0 [ ast-expression boa ] action
] delay ; ] delay ;
MEMO: 'statement' ( -- parser ) : 'statement' ( -- parser )
'expression' ; 'expression' ;
GENERIC: (compile) ( ast -- ) GENERIC: (compile) ( ast -- )
GENERIC: (literal) ( ast -- ) GENERIC: (literal) ( ast -- )
M: ast-number (literal) M: ast-number (literal)
ast-number-value number>string , ; value>> number>string , ;
M: ast-number (compile) M: ast-number (compile)
"factor.push_data(" , "factor.push_data(" ,
@ -196,7 +181,7 @@ M: ast-number (compile)
M: ast-string (literal) M: ast-string (literal)
"\"" , "\"" ,
ast-string-value , value>> ,
"\"" , ; "\"" , ;
M: ast-string (compile) M: ast-string (compile)
@ -205,14 +190,14 @@ M: ast-string (compile)
"," , ; "," , ;
M: ast-identifier (literal) M: ast-identifier (literal)
dup ast-identifier-vocab [ dup vocab>> [
"factor.get_word(\"" , "factor.get_word(\"" ,
dup ast-identifier-vocab , dup vocab>> ,
"\",\"" , "\",\"" ,
ast-identifier-value , value>> ,
"\")" , "\")" ,
] [ ] [
"factor.find_word(\"" , ast-identifier-value , "\")" , "factor.find_word(\"" , value>> , "\")" ,
] if ; ] if ;
M: ast-identifier (compile) M: ast-identifier (compile)
@ -220,9 +205,9 @@ M: ast-identifier (compile)
M: ast-define (compile) M: ast-define (compile)
"factor.define_word(\"" , "factor.define_word(\"" ,
dup ast-define-name , dup name>> ,
"\",\"source\"," , "\",\"source\"," ,
ast-define-expression (compile) expression>> (compile)
"," , ; "," , ;
: do-expressions ( seq -- ) : do-expressions ( seq -- )
@ -242,17 +227,17 @@ M: ast-define (compile)
M: ast-quotation (literal) M: ast-quotation (literal)
"factor.make_quotation(\"source\"," , "factor.make_quotation(\"source\"," ,
ast-quotation-values do-expressions values>> do-expressions
")" , ; ")" , ;
M: ast-quotation (compile) M: ast-quotation (compile)
"factor.push_data(factor.make_quotation(\"source\"," , "factor.push_data(factor.make_quotation(\"source\"," ,
ast-quotation-values do-expressions values>> do-expressions
")," , ; ")," , ;
M: ast-array (literal) M: ast-array (literal)
"[" , "[" ,
ast-array-elements [ "," , ] [ (literal) ] interleave elements>> [ "," , ] [ (literal) ] interleave
"]" , ; "]" , ;
M: ast-array (compile) M: ast-array (compile)
@ -260,7 +245,7 @@ M: ast-array (compile)
M: ast-hashtable (literal) M: ast-hashtable (literal)
"new Hashtable().fromAlist([" , "new Hashtable().fromAlist([" ,
ast-hashtable-elements [ "," , ] [ (literal) ] interleave elements>> [ "," , ] [ (literal) ] interleave
"])" , ; "])" , ;
M: ast-hashtable (compile) M: ast-hashtable (compile)
@ -268,22 +253,22 @@ M: ast-hashtable (compile)
M: ast-expression (literal) M: ast-expression (literal)
ast-expression-values [ values>> [
(literal) (literal)
] each ; ] each ;
M: ast-expression (compile) M: ast-expression (compile)
ast-expression-values do-expressions ; values>> do-expressions ;
M: ast-word (literal) M: ast-word (literal)
dup ast-word-vocab [ dup vocab>> [
"factor.get_word(\"" , "factor.get_word(\"" ,
dup ast-word-vocab , dup vocab>> ,
"\",\"" , "\",\"" ,
ast-word-value , value>> ,
"\")" , "\")" ,
] [ ] [
"factor.find_word(\"" , ast-word-value , "\")" , "factor.find_word(\"" , value>> , "\")" ,
] if ; ] if ;
M: ast-word (compile) M: ast-word (compile)
@ -299,17 +284,17 @@ M: ast-stack-effect (compile)
M: ast-use (compile) M: ast-use (compile)
"factor.use(\"" , "factor.use(\"" ,
ast-use-name , name>> ,
"\"," , ; "\"," , ;
M: ast-in (compile) M: ast-in (compile)
"factor.set_in(\"" , "factor.set_in(\"" ,
ast-in-name , name>> ,
"\"," , ; "\"," , ;
M: ast-using (compile) M: ast-using (compile)
"factor.using([" , "factor.using([" ,
ast-using-names [ names>> [
"," , "," ,
] [ ] [
"\"" , , "\"" , "\"" , , "\"" ,
@ -319,34 +304,34 @@ M: ast-using (compile)
GENERIC: (parse-factor-quotation) ( object -- ast ) GENERIC: (parse-factor-quotation) ( object -- ast )
M: number (parse-factor-quotation) ( object -- ast ) M: number (parse-factor-quotation) ( object -- ast )
<ast-number> ; ast-number boa ;
M: symbol (parse-factor-quotation) ( object -- ast ) M: symbol (parse-factor-quotation) ( object -- ast )
dup >string swap vocabulary>> <ast-identifier> ; dup >string swap vocabulary>> ast-identifier boa ;
M: word (parse-factor-quotation) ( object -- ast ) M: word (parse-factor-quotation) ( object -- ast )
dup name>> swap vocabulary>> <ast-identifier> ; dup name>> swap vocabulary>> ast-identifier boa ;
M: string (parse-factor-quotation) ( object -- ast ) M: string (parse-factor-quotation) ( object -- ast )
<ast-string> ; ast-string boa ;
M: quotation (parse-factor-quotation) ( object -- ast ) M: quotation (parse-factor-quotation) ( object -- ast )
[ [
[ (parse-factor-quotation) , ] each [ (parse-factor-quotation) , ] each
] { } make <ast-quotation> ; ] { } make ast-quotation boa ;
M: array (parse-factor-quotation) ( object -- ast ) M: array (parse-factor-quotation) ( object -- ast )
[ [
[ (parse-factor-quotation) , ] each [ (parse-factor-quotation) , ] each
] { } make <ast-array> ; ] { } make ast-array boa ;
M: hashtable (parse-factor-quotation) ( object -- ast ) M: hashtable (parse-factor-quotation) ( object -- ast )
>alist [ >alist [
[ (parse-factor-quotation) , ] each [ (parse-factor-quotation) , ] each
] { } make <ast-hashtable> ; ] { } make ast-hashtable boa ;
M: wrapper (parse-factor-quotation) ( object -- ast ) M: wrapper (parse-factor-quotation) ( object -- ast )
wrapped>> dup name>> swap vocabulary>> <ast-word> ; wrapped>> dup name>> swap vocabulary>> ast-word boa ;
GENERIC: fjsc-parse ( object -- ast ) GENERIC: fjsc-parse ( object -- ast )
@ -356,7 +341,7 @@ M: string fjsc-parse ( object -- ast )
M: quotation fjsc-parse ( object -- ast ) M: quotation fjsc-parse ( object -- ast )
[ [
[ (parse-factor-quotation) , ] each [ (parse-factor-quotation) , ] each
] { } make <ast-expression> ; ] { } make ast-expression boa ;
: fjsc-compile ( ast -- string ) : fjsc-compile ( ast -- string )
[ [
@ -372,7 +357,7 @@ M: quotation fjsc-parse ( object -- ast )
: fc* ( string -- string ) : fc* ( string -- string )
[ [
'statement' parse parse-result-ast ast-expression-values do-expressions 'statement' parse parse-result-ast values>> do-expressions
] { } make [ write ] each ; ] { } make [ write ] each ;

6
extra/fry/fry-docs.factor
View File

@ -40,9 +40,9 @@ $nl
} }
"Occurrences of " { $link @ } " are simply syntax sugar for " { $snippet ", call" } ". The following three lines are equivalent:" "Occurrences of " { $link @ } " are simply syntax sugar for " { $snippet ", call" } ". The following three lines are equivalent:"
{ $code { $code
"{ 10 20 30 } [ sq ] '[ @ . ] map" "{ 10 20 30 } [ sq ] '[ @ . ] each"
"{ 10 20 30 } [ sq ] [ . ] compose map" "{ 10 20 30 } [ sq ] [ . ] compose each"
"{ 10 20 30 } [ sq . ] map" "{ 10 20 30 } [ sq . ] each"
} }
"The " { $link , } " and " { $link @ } " specifiers may be freely mixed:" "The " { $link , } " and " { $link @ } " specifiers may be freely mixed:"
{ $code { $code

7
extra/irc/client/client-tests.factor
View File

@ -1,8 +1,9 @@
USING: kernel tools.test accessors arrays sequences qualified USING: kernel tools.test accessors arrays sequences qualified
io.streams.string io.streams.duplex namespaces threads io.streams.string io.streams.duplex namespaces threads
calendar irc.client.private concurrency.mailboxes classes ; calendar irc.client.private irc.client irc.messages.private
EXCLUDE: irc.client => join ; concurrency.mailboxes classes ;
RENAME: join irc.client => join_ EXCLUDE: irc.messages => join ;
RENAME: join irc.messages => join_
IN: irc.client.tests IN: irc.client.tests
! Utilities ! Utilities

2
extra/lisp/lisp.factor
View File

@ -99,7 +99,7 @@ PRIVATE>
uncons [ list>seq [ ] like ] [ lookup-macro lambda-rewrite call ] bi* call compile-form call ; uncons [ list>seq [ ] like ] [ lookup-macro lambda-rewrite call ] bi* call compile-form call ;
: lisp-string>factor ( str -- quot ) : lisp-string>factor ( str -- quot )
lisp-expr parse-result-ast compile-form ; lisp-expr compile-form ;
: lisp-eval ( str -- * ) : lisp-eval ( str -- * )
lisp-string>factor call ; lisp-string>factor call ;

24
extra/lisp/parser/parser-tests.factor
View File

@ -5,43 +5,43 @@ USING: lisp.parser tools.test peg peg.ebnf lists ;
IN: lisp.parser.tests IN: lisp.parser.tests
{ 1234 } [ { 1234 } [
"1234" "atom" \ lisp-expr rule parse parse-result-ast "1234" "atom" \ lisp-expr rule parse
] unit-test ] unit-test
{ -42 } [ { -42 } [
"-42" "atom" \ lisp-expr rule parse parse-result-ast "-42" "atom" \ lisp-expr rule parse
] unit-test ] unit-test
{ 37/52 } [ { 37/52 } [
"37/52" "atom" \ lisp-expr rule parse parse-result-ast "37/52" "atom" \ lisp-expr rule parse
] unit-test ] unit-test
{ 123.98 } [ { 123.98 } [
"123.98" "atom" \ lisp-expr rule parse parse-result-ast "123.98" "atom" \ lisp-expr rule parse
] unit-test ] unit-test
{ "" } [ { "" } [
"\"\"" "atom" \ lisp-expr rule parse parse-result-ast "\"\"" "atom" \ lisp-expr rule parse
] unit-test ] unit-test
{ "aoeu" } [ { "aoeu" } [
"\"aoeu\"" "atom" \ lisp-expr rule parse parse-result-ast "\"aoeu\"" "atom" \ lisp-expr rule parse
] unit-test ] unit-test
{ "aoeu\"de" } [ { "aoeu\"de" } [
"\"aoeu\\\"de\"" "atom" \ lisp-expr rule parse parse-result-ast "\"aoeu\\\"de\"" "atom" \ lisp-expr rule parse
] unit-test ] unit-test
{ T{ lisp-symbol f "foobar" } } [ { T{ lisp-symbol f "foobar" } } [
"foobar" "atom" \ lisp-expr rule parse parse-result-ast "foobar" "atom" \ lisp-expr rule parse
] unit-test ] unit-test
{ T{ lisp-symbol f "+" } } [ { T{ lisp-symbol f "+" } } [
"+" "atom" \ lisp-expr rule parse parse-result-ast "+" "atom" \ lisp-expr rule parse
] unit-test ] unit-test
{ +nil+ } [ { +nil+ } [
"()" lisp-expr parse-result-ast "()" lisp-expr
] unit-test ] unit-test
{ T{ { T{
@ -54,7 +54,7 @@ IN: lisp.parser.tests
1 1
T{ cons f 2 T{ cons f "aoeu" +nil+ } } T{ cons f 2 T{ cons f "aoeu" +nil+ } }
} } } [ } } } [
"(foo 1 2 \"aoeu\")" lisp-expr parse-result-ast "(foo 1 2 \"aoeu\")" lisp-expr
] unit-test ] unit-test
{ T{ cons f { T{ cons f
@ -64,5 +64,5 @@ IN: lisp.parser.tests
T{ cons f 2 +nil+ } } T{ cons f 2 +nil+ } }
} }
} [ } [
"(1 (3 4) 2)" lisp-expr parse-result-ast "(1 (3 4) 2)" lisp-expr
] unit-test ] unit-test

19
extra/models/compose/compose.factor
View File

@ -1,19 +1,24 @@
USING: models kernel sequences ; ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors models kernel sequences ;
IN: models.compose IN: models.compose
TUPLE: compose ; TUPLE: compose < model ;
: new-compose ( models class -- compose )
f swap new-model
swap clone >>dependencies ; inline
: <compose> ( models -- compose ) : <compose> ( models -- compose )
f compose construct-model compose new-compose ;
swap clone over set-model-dependencies ;
: composed-value >r model-dependencies r> map ; inline : composed-value [ dependencies>> ] dip map ; inline
: set-composed-value >r model-dependencies r> 2each ; inline : set-composed-value [ dependencies>> ] dip 2each ; inline
M: compose model-changed M: compose model-changed
nip nip
dup [ model-value ] composed-value swap delegate set-model ; [ [ model-value ] composed-value ] keep set-model ;
M: compose model-activated dup model-changed ; M: compose model-activated dup model-changed ;

22
extra/models/delay/delay.factor
View File

@ -1,24 +1,26 @@
USING: kernel models alarms ; ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel models alarms ;
IN: models.delay IN: models.delay
TUPLE: delay model timeout alarm ; TUPLE: delay < model model timeout alarm ;
: update-delay-model ( delay -- ) : update-delay-model ( delay -- )
dup delay-model model-value swap set-model ; [ delay-model model-value ] keep set-model ;
: <delay> ( model timeout -- delay ) : <delay> ( model timeout -- delay )
f delay construct-model f delay new-model
[ set-delay-timeout ] keep swap >>timeout
[ set-delay-model ] 2keep over >>model
[ add-dependency ] keep ; [ add-dependency ] keep ;
: cancel-delay ( delay -- ) : cancel-delay ( delay -- )
delay-alarm [ cancel-alarm ] when* ; delay-alarm [ cancel-alarm ] when* ;
: start-delay ( delay -- ) : start-delay ( delay -- )
dup [ f over set-delay-alarm update-delay-model ] curry dup
over delay-timeout later [ [ f >>alarm update-delay-model ] curry ] [ timeout>> ] bi later
swap set-delay-alarm ; >>alarm drop ;
M: delay model-changed nip dup cancel-delay start-delay ; M: delay model-changed nip dup cancel-delay start-delay ;

19
extra/models/filter/filter.factor
View File

@ -1,16 +1,17 @@
USING: models kernel ; ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors models kernel ;
IN: models.filter IN: models.filter
TUPLE: filter model quot ; TUPLE: filter < model model quot ;
: <filter> ( model quot -- filter ) : <filter> ( model quot -- filter )
f filter construct-model f filter new-model
[ set-filter-quot ] keep swap >>quot
[ set-filter-model ] 2keep over >>model
[ add-dependency ] keep ; [ add-dependency ] keep ;
M: filter model-changed M: filter model-changed
swap model-value over filter-quot call [ [ value>> ] [ quot>> ] bi* call ] [ nip ] 2bi set-model ;
swap set-model ;
M: filter model-activated dup filter-model swap model-changed ; M: filter model-activated [ model>> ] keep model-changed ;

15
extra/models/history/history.factor
View File

@ -1,14 +1,17 @@
USING: kernel models sequences ; ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel models sequences ;
IN: models.history IN: models.history
TUPLE: history back forward ; TUPLE: history < model back forward ;
: reset-history ( history -- ) : reset-history ( history -- history )
V{ } clone over set-history-back V{ } clone >>back
V{ } clone swap set-history-forward ; V{ } clone >>forward ; inline
: <history> ( value -- history ) : <history> ( value -- history )
history construct-model dup reset-history ; history new-model
reset-history ;
: (add-history) ( history to -- ) : (add-history) ( history to -- )
swap model-value dup [ swap push ] [ 2drop ] if ; swap model-value dup [ swap push ] [ 2drop ] if ;

21
extra/models/mapping/mapping.factor
View File

@ -1,20 +1,21 @@
USING: models kernel assocs ; ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors models kernel assocs ;
IN: models.mapping IN: models.mapping
TUPLE: mapping assoc ; TUPLE: mapping < model assoc ;
: <mapping> ( models -- mapping ) : <mapping> ( models -- mapping )
f mapping construct-model f mapping new-model
over values over set-model-dependencies over values >>dependencies
tuck set-mapping-assoc ; swap >>assoc ;
M: mapping model-changed M: mapping model-changed
nip nip [ assoc>> [ value>> ] assoc-map ] keep set-model ;
dup mapping-assoc [ model-value ] assoc-map
swap delegate set-model ;
M: mapping model-activated dup model-changed ; M: mapping model-activated
dup model-changed ;
M: mapping update-model M: mapping update-model
dup model-value swap mapping-assoc [ value>> ] [ assoc>> ] bi
[ swapd at set-model ] curry assoc-each ; [ swapd at set-model ] curry assoc-each ;

3
extra/models/models.factor
View File

@ -100,9 +100,6 @@ M: model update-model drop ;
: (change-model) ( model quot -- ) : (change-model) ( model quot -- )
((change-model)) set-model-value ; inline ((change-model)) set-model-value ; inline
: construct-model ( value class -- instance )
>r <model> { set-delegate } r> construct ; inline
GENERIC: range-value ( model -- value ) GENERIC: range-value ( model -- value )
GENERIC: range-page-value ( model -- value ) GENERIC: range-page-value ( model -- value )
GENERIC: range-min-value ( model -- value ) GENERIC: range-min-value ( model -- value )

29
extra/models/range/range.factor
View File

@ -1,32 +1,33 @@
USING: kernel models arrays sequences math math.order ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel models arrays sequences math math.order
models.compose ; models.compose ;
IN: models.range IN: models.range
TUPLE: range ; TUPLE: range < compose ;
: <range> ( value min max page -- range ) : <range> ( value min max page -- range )
4array [ <model> ] map <compose> 4array [ <model> ] map range new-compose ;
{ set-delegate } range construct ;
: range-model ( range -- model ) model-dependencies first ; : range-model ( range -- model ) dependencies>> first ;
: range-page ( range -- model ) model-dependencies second ; : range-page ( range -- model ) dependencies>> second ;
: range-min ( range -- model ) model-dependencies third ; : range-min ( range -- model ) dependencies>> third ;
: range-max ( range -- model ) model-dependencies fourth ; : range-max ( range -- model ) dependencies>> fourth ;
M: range range-value M: range range-value
[ range-model model-value ] keep clamp-value ; [ range-model value>> ] keep clamp-value ;
M: range range-page-value range-page model-value ; M: range range-page-value range-page value>> ;
M: range range-min-value range-min model-value ; M: range range-min-value range-min value>> ;
M: range range-max-value range-max model-value ; M: range range-max-value range-max value>> ;
M: range range-max-value* M: range range-max-value*
dup range-max-value swap range-page-value [-] ; [ range-max-value ] [ range-page-value ] bi [-] ;
M: range set-range-value M: range set-range-value
[ clamp-value ] keep range-model set-model ; [ clamp-value ] [ range-model ] bi set-model ;
M: range set-range-page-value range-page set-model ; M: range set-range-page-value range-page set-model ;

2
extra/peg/parsers/parsers.factor
View File

@ -17,7 +17,7 @@ TUPLE: just-parser p1 ;
M: just-parser (compile) ( parser -- quot ) M: just-parser (compile) ( parser -- quot )
just-parser-p1 compiled-parser just-pattern curry ; just-parser-p1 compile-parser just-pattern curry ;
: just ( parser -- parser ) : just ( parser -- parser )
just-parser boa wrap-peg ; just-parser boa wrap-peg ;

50
extra/peg/peg.factor
View File

@ -2,8 +2,9 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences strings fry namespaces math assocs shuffle debugger io USING: kernel sequences strings fry namespaces math assocs shuffle debugger io
vectors arrays math.parser math.order vectors combinators combinators.lib vectors arrays math.parser math.order vectors combinators combinators.lib
combinators.short-circuit classes sets unicode.categories compiler.units parser classes sets unicode.categories compiler.units parser
words quotations effects memoize accessors locals effects splitting ; words quotations effects memoize accessors locals effects splitting
combinators.short-circuit combinators.short-circuit.smart ;
IN: peg IN: peg
USE: prettyprint USE: prettyprint
@ -279,7 +280,13 @@ GENERIC: (compile) ( peg -- quot )
gensym 2dup swap peg>> (compile) 0 1 <effect> define-declared swap dupd id>> "peg-id" set-word-prop gensym 2dup swap peg>> (compile) 0 1 <effect> define-declared swap dupd id>> "peg-id" set-word-prop
[ execute-parser ] curry ; [ execute-parser ] curry ;
: compiled-parser ( parser -- word ) : preset-parser-word ( parser -- parser word )
gensym [ >>compiled ] keep ;
: define-parser-word ( parser word -- )
swap parser-body (( -- result )) define-declared ;
: compile-parser ( parser -- word )
#! Look to see if the given parser has been compiled. #! Look to see if the given parser has been compiled.
#! If not, compile it to a temporary word, cache it, #! If not, compile it to a temporary word, cache it,
#! and return it. Otherwise return the existing one. #! and return it. Otherwise return the existing one.
@ -289,7 +296,7 @@ GENERIC: (compile) ( peg -- quot )
dup compiled>> [ dup compiled>> [
nip nip
] [ ] [
gensym tuck >>compiled 2dup parser-body 0 1 <effect> define-declared dupd "peg" set-word-prop preset-parser-word [ define-parser-word ] keep
] if* ; ] if* ;
SYMBOL: delayed SYMBOL: delayed
@ -298,13 +305,13 @@ SYMBOL: delayed
#! Work through all delayed parsers and recompile their #! Work through all delayed parsers and recompile their
#! words to have the correct bodies. #! words to have the correct bodies.
delayed get [ delayed get [
call compiled-parser 1quotation 0 1 <effect> define-declared call compile-parser 1quotation 0 1 <effect> define-declared
] assoc-each ; ] assoc-each ;
: compile ( parser -- word ) : compile ( parser -- word )
[ [
H{ } clone delayed [ H{ } clone delayed [
compiled-parser fixup-delayed compile-parser fixup-delayed
] with-variable ] with-variable
] with-compilation-unit ; ] with-compilation-unit ;
@ -410,17 +417,20 @@ TUPLE: seq-parser parsers ;
M: seq-parser (compile) ( peg -- quot ) M: seq-parser (compile) ( peg -- quot )
[ [
[ input-slice V{ } clone <parse-result> ] % [ input-slice V{ } clone <parse-result> ] %
parsers>> unclip compiled-parser 1quotation , \ parse-seq-element , [ [
compiled-parser 1quotation [ merge-errors ] compose , \ parse-seq-element , ] each parsers>> unclip compile-parser 1quotation [ parse-seq-element ] curry ,
[ compile-parser 1quotation [ merge-errors ] compose [ parse-seq-element ] curry , ] each
] { } make , \ && ,
] [ ] make ; ] [ ] make ;
TUPLE: choice-parser parsers ; TUPLE: choice-parser parsers ;
M: choice-parser (compile) ( peg -- quot ) M: choice-parser (compile) ( peg -- quot )
[ [
f , [
parsers>> [ compiled-parser ] map parsers>> [ compile-parser ] map
unclip 1quotation , \ unless* , [ 1quotation [ merge-errors ] compose , \ unless* , ] each unclip 1quotation , [ 1quotation [ merge-errors ] compose , ] each
] { } make , \ || ,
] [ ] make ; ] [ ] make ;
TUPLE: repeat0-parser p1 ; TUPLE: repeat0-parser p1 ;
@ -435,7 +445,7 @@ TUPLE: repeat0-parser p1 ;
] if* ; inline ] if* ; inline
M: repeat0-parser (compile) ( peg -- quot ) M: repeat0-parser (compile) ( peg -- quot )
p1>> compiled-parser 1quotation '[ p1>> compile-parser 1quotation '[
input-slice V{ } clone <parse-result> , swap (repeat) input-slice V{ } clone <parse-result> , swap (repeat)
] ; ] ;
@ -449,7 +459,7 @@ TUPLE: repeat1-parser p1 ;
] if* ; ] if* ;
M: repeat1-parser (compile) ( peg -- quot ) M: repeat1-parser (compile) ( peg -- quot )
p1>> compiled-parser 1quotation '[ p1>> compile-parser 1quotation '[
input-slice V{ } clone <parse-result> , swap (repeat) repeat1-empty-check input-slice V{ } clone <parse-result> , swap (repeat) repeat1-empty-check
] ; ] ;
@ -459,7 +469,7 @@ TUPLE: optional-parser p1 ;
[ input-slice f <parse-result> ] unless* ; [ input-slice f <parse-result> ] unless* ;
M: optional-parser (compile) ( peg -- quot ) M: optional-parser (compile) ( peg -- quot )
p1>> compiled-parser 1quotation '[ @ check-optional ] ; p1>> compile-parser 1quotation '[ @ check-optional ] ;
TUPLE: semantic-parser p1 quot ; TUPLE: semantic-parser p1 quot ;
@ -471,7 +481,7 @@ TUPLE: semantic-parser p1 quot ;
] if ; inline ] if ; inline
M: semantic-parser (compile) ( peg -- quot ) M: semantic-parser (compile) ( peg -- quot )
[ p1>> compiled-parser 1quotation ] [ quot>> ] bi [ p1>> compile-parser 1quotation ] [ quot>> ] bi
'[ @ , check-semantic ] ; '[ @ , check-semantic ] ;
TUPLE: ensure-parser p1 ; TUPLE: ensure-parser p1 ;
@ -480,7 +490,7 @@ TUPLE: ensure-parser p1 ;
[ ignore <parse-result> ] [ drop f ] if ; [ ignore <parse-result> ] [ drop f ] if ;
M: ensure-parser (compile) ( peg -- quot ) M: ensure-parser (compile) ( peg -- quot )
p1>> compiled-parser 1quotation '[ input-slice @ check-ensure ] ; p1>> compile-parser 1quotation '[ input-slice @ check-ensure ] ;
TUPLE: ensure-not-parser p1 ; TUPLE: ensure-not-parser p1 ;
@ -488,7 +498,7 @@ TUPLE: ensure-not-parser p1 ;
[ drop f ] [ ignore <parse-result> ] if ; [ drop f ] [ ignore <parse-result> ] if ;
M: ensure-not-parser (compile) ( peg -- quot ) M: ensure-not-parser (compile) ( peg -- quot )
p1>> compiled-parser 1quotation '[ input-slice @ check-ensure-not ] ; p1>> compile-parser 1quotation '[ input-slice @ check-ensure-not ] ;
TUPLE: action-parser p1 quot ; TUPLE: action-parser p1 quot ;
@ -500,7 +510,7 @@ TUPLE: action-parser p1 quot ;
] if ; inline ] if ; inline
M: action-parser (compile) ( peg -- quot ) M: action-parser (compile) ( peg -- quot )
[ p1>> compiled-parser 1quotation ] [ quot>> ] bi '[ @ , check-action ] ; [ p1>> compile-parser 1quotation ] [ quot>> ] bi '[ @ , check-action ] ;
: left-trim-slice ( string -- string ) : left-trim-slice ( string -- string )
#! Return a new string without any leading whitespace #! Return a new string without any leading whitespace
@ -512,7 +522,7 @@ M: action-parser (compile) ( peg -- quot )
TUPLE: sp-parser p1 ; TUPLE: sp-parser p1 ;
M: sp-parser (compile) ( peg -- quot ) M: sp-parser (compile) ( peg -- quot )
p1>> compiled-parser 1quotation '[ p1>> compile-parser 1quotation '[
input-slice left-trim-slice input-from pos set @ input-slice left-trim-slice input-from pos set @
] ; ] ;
@ -531,7 +541,7 @@ M: box-parser (compile) ( peg -- quot )
#! to produce the parser to be compiled. #! to produce the parser to be compiled.
#! This differs from 'delay' which calls #! This differs from 'delay' which calls
#! it at run time. #! it at run time.
quot>> call compiled-parser 1quotation ; quot>> call compile-parser 1quotation ;
PRIVATE> PRIVATE>

10
extra/slides/slides.factor
View File

@ -1,3 +1,5 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays hashtables help.markup help.stylesheet io USING: arrays hashtables help.markup help.stylesheet io
io.styles kernel math models namespaces sequences ui ui.gadgets io.styles kernel math models namespaces sequences ui ui.gadgets
ui.gadgets.books ui.gadgets.panes ui.gestures ui.render ui.gadgets.books ui.gadgets.panes ui.gestures ui.render
@ -70,12 +72,10 @@ IN: slides
$divider $divider
$list ; $list ;
TUPLE: slides ; TUPLE: slides < book ;
: <slides> ( slides -- gadget ) : <slides> ( slides -- gadget )
[ <page> ] map 0 <model> <book> [ <page> ] map 0 <model> slides new-book ;
slides construct-gadget
[ set-gadget-delegate ] keep ;
: change-page ( book n -- ) : change-page ( book n -- )
over control-value + over gadget-children length rem over control-value + over gadget-children length rem
@ -103,5 +103,3 @@ TUPLE: slides ;
: slides-window ( slides -- ) : slides-window ( slides -- )
[ <slides> "Slides" open-window ] with-ui ; [ <slides> "Slides" open-window ] with-ui ;
MAIN: slides-window

16
extra/ui/cocoa/cocoa.factor
View File

@ -1,11 +1,11 @@
! Copyright (C) 2006, 2008 Slava Pestov. ! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: math arrays cocoa cocoa.application command-line USING: accessors math arrays cocoa cocoa.application
kernel memory namespaces cocoa.messages cocoa.runtime command-line kernel memory namespaces cocoa.messages
cocoa.subclassing cocoa.pasteboard cocoa.types cocoa.windows cocoa.runtime cocoa.subclassing cocoa.pasteboard cocoa.types
cocoa.classes cocoa.application sequences system ui ui.backend cocoa.windows cocoa.classes cocoa.application sequences system
ui.clipboards ui.gadgets ui.gadgets.worlds ui.cocoa.views ui ui.backend ui.clipboards ui.gadgets ui.gadgets.worlds
core-foundation threads ; ui.cocoa.views core-foundation threads ;
IN: ui.cocoa IN: ui.cocoa
TUPLE: handle view window ; TUPLE: handle view window ;
@ -38,7 +38,7 @@ M: pasteboard set-clipboard-contents
<clipboard> selection set-global ; <clipboard> selection set-global ;
: world>NSRect ( world -- NSRect ) : world>NSRect ( world -- NSRect )
dup world-loc first2 rot rect-dim first2 <NSRect> ; dup window-loc>> first2 rot rect-dim first2 <NSRect> ;
: gadget-window ( world -- ) : gadget-window ( world -- )
[ [
@ -68,7 +68,7 @@ M: cocoa-ui-backend fullscreen* ( world -- ? )
world-handle handle-view -> isInFullScreenMode zero? not ; world-handle handle-view -> isInFullScreenMode zero? not ;
: auto-position ( world -- ) : auto-position ( world -- )
dup world-loc { 0 0 } = [ dup window-loc>> { 0 0 } = [
world-handle handle-window -> center world-handle handle-window -> center
] [ ] [
drop drop

11
extra/ui/cocoa/views/views.factor
View File

@ -1,9 +1,10 @@
! Copyright (C) 2006, 2008 Slava Pestov ! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays assocs cocoa kernel math cocoa.messages USING: accessors alien alien.c-types arrays assocs cocoa kernel
cocoa.subclassing cocoa.classes cocoa.views cocoa.application math cocoa.messages cocoa.subclassing cocoa.classes cocoa.views
cocoa.pasteboard cocoa.types cocoa.windows sequences ui ui.gadgets cocoa.application cocoa.pasteboard cocoa.types cocoa.windows
ui.gadgets.worlds ui.gestures core-foundation threads combinators ; sequences ui ui.gadgets ui.gadgets.worlds ui.gestures
core-foundation threads combinators ;
IN: ui.cocoa.views IN: ui.cocoa.views
: send-mouse-moved ( view event -- ) : send-mouse-moved ( view event -- )
@ -377,7 +378,7 @@ CLASS: {
[ [
2nip -> object 2nip -> object
dup window-content-rect NSRect-x-y 2array dup window-content-rect NSRect-x-y 2array
swap -> contentView window set-world-loc swap -> contentView window (>>window-loc)
] ]
} }

19
extra/ui/commands/commands-docs.factor
View File

@ -1,22 +1,21 @@
USING: ui.gestures help.markup help.syntax strings kernel USING: accessors ui.gestures help.markup help.syntax strings kernel
hashtables quotations words classes sequences namespaces hashtables quotations words classes sequences namespaces
arrays assocs ; arrays assocs ;
IN: ui.commands IN: ui.commands
: command-map-row ( children -- seq ) : command-map-row ( gesture command -- seq )
[ [
[ first gesture>string , ] [ gesture>string , ]
[ [
second
[ command-name , ] [ command-name , ]
[ command-word \ $link swap 2array , ] [ command-word \ $link swap 2array , ]
[ command-description , ] [ command-description , ]
tri tri
] bi ] bi*
] { } make ; ] { } make ;
: command-map. ( command-map -- ) : command-map. ( alist -- )
[ command-map-row ] map [ command-map-row ] { } assoc>map
{ "Shortcut" "Command" "Word" "Notes" } { "Shortcut" "Command" "Word" "Notes" }
[ \ $strong swap ] { } map>assoc prefix [ \ $strong swap ] { } map>assoc prefix
$table ; $table ;
@ -25,11 +24,13 @@ IN: ui.commands
[ second (command-name) " commands" append $heading ] [ second (command-name) " commands" append $heading ]
[ [
first2 swap command-map first2 swap command-map
[ command-map-blurb print-element ] [ command-map. ] bi [ blurb>> print-element ] [ commands>> command-map. ] bi
] bi ; ] bi ;
: $command ( element -- ) : $command ( element -- )
reverse first3 command-map value-at gesture>string $snippet ; reverse first3 command-map
commands>> value-at gesture>string
$snippet ;
HELP: +nullary+ HELP: +nullary+
{ $description "A key which may be set in the hashtable passed to " { $link define-command } ". If set to a true value, the command does not take any inputs, and the value passed to " { $link invoke-command } " will be ignored. Otherwise, it takes one input." } ; { $description "A key which may be set in the hashtable passed to " { $link define-command } ". If set to a true value, the command does not take any inputs, and the value passed to " { $link invoke-command } " will be ignored. Otherwise, it takes one input." } ;

11
extra/ui/commands/commands.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2006, 2007 Slava Pestov. ! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays definitions kernel sequences strings USING: accessors arrays definitions kernel sequences strings
math assocs words generic namespaces assocs quotations splitting math assocs words generic namespaces assocs quotations splitting
@ -15,16 +15,14 @@ GENERIC: invoke-command ( target command -- )
GENERIC: command-name ( command -- str ) GENERIC: command-name ( command -- str )
TUPLE: command-map blurb ; TUPLE: command-map blurb commands ;
GENERIC: command-description ( command -- str/f ) GENERIC: command-description ( command -- str/f )
GENERIC: command-word ( command -- word ) GENERIC: command-word ( command -- word )
: <command-map> ( blurb commands -- command-map ) : <command-map> ( blurb commands -- command-map )
{ } like { } like \ command-map boa ;
{ set-command-map-blurb set-delegate }
\ command-map construct ;
: commands ( class -- hash ) : commands ( class -- hash )
dup "commands" word-prop [ ] [ dup "commands" word-prop [ ] [
@ -37,7 +35,8 @@ GENERIC: command-word ( command -- word )
: command-gestures ( class -- hash ) : command-gestures ( class -- hash )
commands values [ commands values [
[ [
[ first ] filter commands>>
[ drop ] assoc-filter
[ [ invoke-command ] curry swap set ] assoc-each [ [ invoke-command ] curry swap set ] assoc-each
] each ] each
] H{ } make-assoc ; ] H{ } make-assoc ;

7
extra/ui/gadgets/books/books-docs.factor
View File

@ -9,3 +9,10 @@ $nl
HELP: <book> HELP: <book>
{ $values { "pages" "a sequence of gadgets" } { "model" model } { "book" book } } { $values { "pages" "a sequence of gadgets" } { "model" model } { "book" book } }
{ $description "Creates a " { $link book } " control, which contains the gadgets in " { $snippet "pages" } ". A book shows one child at a time, determined by the value of the model, which must be an integer " } ; { $description "Creates a " { $link book } " control, which contains the gadgets in " { $snippet "pages" } ". A book shows one child at a time, determined by the value of the model, which must be an integer " } ;
ARTICLE: "ui-book-layout" "Book layouts"
"Books can contain any number of children, and display one child at a time."
{ $subsection book }
{ $subsection <book> } ;
ABOUT: "ui-book-layout"

13
extra/ui/gadgets/books/books.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2006, 2007 Slava Pestov. ! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences models ui.gadgets ; USING: accessors kernel sequences models ui.gadgets ;
IN: ui.gadgets.books IN: ui.gadgets.books
TUPLE: book ; TUPLE: book < gadget ;
: hide-all ( book -- ) gadget-children [ hide-gadget ] each ; : hide-all ( book -- ) gadget-children [ hide-gadget ] each ;
@ -16,8 +16,13 @@ M: book model-changed
dup current-page show-gadget dup current-page show-gadget
relayout ; relayout ;
: new-book ( pages model class -- book )
new-gadget
swap >>model
[ add-gadgets ] keep ; inline
: <book> ( pages model -- book ) : <book> ( pages model -- book )
<gadget> book construct-control [ add-gadgets ] keep ; book new-book ;
M: book pref-dim* gadget-children pref-dims max-dim ; M: book pref-dim* gadget-children pref-dims max-dim ;

25
extra/ui/gadgets/borders/borders-tests.factor Normal file
View File

@ -0,0 +1,25 @@
IN: ui.gadgets.borders.tests
USING: tools.test accessors namespaces kernel
ui.gadgets ui.gadgets.borders ;
[ { 110 210 } ] [ <gadget> { 100 200 } >>dim 5 <border> pref-dim ] unit-test
[ ] [ <gadget> { 100 200 } >>dim "g" set ] unit-test
[ ] [ "g" get 0 <border> { 100 200 } >>dim "b" set ] unit-test
[ T{ rect f { 0 0 } { 100 200 } } ] [ "b" get border-child-rect ] unit-test
[ ] [ "g" get 5 <border> { 210 210 } >>dim "b" set ] unit-test
[ T{ rect f { 55 5 } { 100 200 } } ] [ "b" get border-child-rect ] unit-test
[ ] [ "b" get { 0 0 } >>align drop ] unit-test
[ { 5 5 } ] [ "b" get { 100 200 } border-loc ] unit-test
[ T{ rect f { 5 5 } { 100 200 } } ] [ "b" get border-child-rect ] unit-test
[ ] [ "b" get { 1 1 } >>fill drop ] unit-test
[ T{ rect f { 5 5 } { 200 200 } } ] [ "b" get border-child-rect ] unit-test

50
extra/ui/gadgets/borders/borders.factor
View File

@ -1,45 +1,47 @@
! Copyright (C) 2005, 2007 Slava Pestov. ! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays ui.gadgets generic hashtables kernel math USING: accessors arrays ui.gadgets kernel math
namespaces vectors sequences math.vectors ; namespaces vectors sequences math.vectors ;
IN: ui.gadgets.borders IN: ui.gadgets.borders
TUPLE: border size fill ; TUPLE: border < gadget
{ size initial: { 0 0 } }
{ fill initial: { 0 0 } }
{ align initial: { 1/2 1/2 } } ;
: new-border ( child class -- border )
new-gadget [ add-gadget ] keep ; inline
: <border> ( child gap -- border ) : <border> ( child gap -- border )
dup 2array { 0 0 } border boa swap border new-border
<gadget> over set-delegate swap dup 2array >>size ;
tuck add-gadget ;
M: border pref-dim* M: border pref-dim*
[ border-size 2 v*n ] keep [ size>> 2 v*n ] keep
gadget-child pref-dim v+ ; gadget-child pref-dim v+ ;
: border-major-rect ( border -- rect ) : border-major-dim ( border -- dim )
dup border-size swap rect-dim over 2 v*n v- <rect> ; [ dim>> ] [ size>> 2 v*n ] bi v- ;
: border-minor-rect ( major border -- rect ) : border-minor-dim ( border -- dim )
gadget-child pref-dim gadget-child pref-dim ;
[ >r rect-bounds r> v- [ 2 / >fixnum ] map v+ ] keep
<rect> ;
: scale-rect ( rect vec -- loc dim ) : scale ( a b s -- c )
[ v* ] curry >r rect-bounds r> bi@ ; tuck { 1 1 } swap v- [ v* ] 2bi@ v+ ;
: average-rects ( rect1 rect2 weight -- rect ) : border-dim ( border -- dim )
tuck >r >r scale-rect r> r> { 1 1 } swap v- scale-rect [ border-major-dim ] [ border-minor-dim ] [ fill>> ] tri scale ;
swapd v+ >r v+ r> <rect> ;
: border-loc ( border dim -- loc )
[ [ size>> ] [ align>> ] [ border-major-dim ] tri ] dip v- v* v+ ;
: border-child-rect ( border -- rect ) : border-child-rect ( border -- rect )
dup border-major-rect dup border-dim [ border-loc ] keep <rect> ;
dup pick border-minor-rect
rot border-fill
average-rects ;
M: border layout* M: border layout*
dup border-child-rect swap gadget-child dup border-child-rect swap gadget-child
over rect-loc over set-rect-loc over loc>> over set-rect-loc
swap rect-dim swap set-layout-dim ; swap dim>> swap set-layout-dim ;
M: border focusable-child* M: border focusable-child*
gadget-child ; gadget-child ;

2
extra/ui/gadgets/buttons/buttons-tests.factor
View File

@ -16,7 +16,7 @@ TUPLE: foo-gadget ;
T{ foo-gadget } <toolbar> "t" set T{ foo-gadget } <toolbar> "t" set
[ 2 ] [ "t" get gadget-children length ] unit-test [ 2 ] [ "t" get gadget-children length ] unit-test
[ "Foo A" ] [ "t" get gadget-child gadget-child label-string ] unit-test [ "Foo A" ] [ "t" get gadget-child gadget-child gadget-child label-string ] unit-test
[ ] [ [ ] [
2 <model> { 2 <model> {

72
extra/ui/gadgets/buttons/buttons.factor
View File

@ -1,14 +1,15 @@
! Copyright (C) 2005, 2008 Slava Pestov. ! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays ui.commands ui.gadgets ui.gadgets.borders USING: accessors arrays kernel math models namespaces sequences
strings quotations assocs combinators classes colors
classes.tuple opengl math.vectors
ui.commands ui.gadgets ui.gadgets.borders
ui.gadgets.labels ui.gadgets.theme ui.gadgets.labels ui.gadgets.theme
ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures
ui.render kernel math models namespaces sequences strings ui.render ;
quotations assocs combinators classes colors classes.tuple
opengl math.vectors ;
IN: ui.gadgets.buttons IN: ui.gadgets.buttons
TUPLE: button pressed? selected? quot ; TUPLE: button < border pressed? selected? quot ;
: buttons-down? ( -- ? ) : buttons-down? ( -- ? )
hand-buttons get-global empty? not ; hand-buttons get-global empty? not ;
@ -39,10 +40,11 @@ button H{
{ T{ mouse-enter } [ button-update ] } { T{ mouse-enter } [ button-update ] }
} set-gestures } set-gestures
: <button> ( gadget quot -- button ) : new-button ( label quot class -- button )
button new [ swap >label ] dip new-border swap >>quot ; inline
swap >>quot
[ set-gadget-delegate ] keep ; : <button> ( label quot -- button )
button new-button ;
TUPLE: button-paint plain rollover pressed selected ; TUPLE: button-paint plain rollover pressed selected ;
@ -66,10 +68,11 @@ M: button-paint draw-boundary
button-paint draw-boundary ; button-paint draw-boundary ;
: roll-button-theme ( button -- button ) : roll-button-theme ( button -- button )
f black <solid> dup f <button-paint> >>boundary ; inline f black <solid> dup f <button-paint> >>boundary
{ 0 1/2 } >>align ; inline
: <roll-button> ( label quot -- button ) : <roll-button> ( label quot -- button )
>r >label r> <button> roll-button-theme ; <button> roll-button-theme ;
: <bevel-button-paint> ( -- paint ) : <bevel-button-paint> ( -- paint )
plain-gradient plain-gradient
@ -80,13 +83,13 @@ M: button-paint draw-boundary
: bevel-button-theme ( gadget -- gadget ) : bevel-button-theme ( gadget -- gadget )
<bevel-button-paint> >>interior <bevel-button-paint> >>interior
{ 5 5 } >>size
faint-boundary ; inline faint-boundary ; inline
: <bevel-button> ( label quot -- button ) : <bevel-button> ( label quot -- button )
>r >label 5 <border> r>
<button> bevel-button-theme ; <button> bevel-button-theme ;
TUPLE: repeat-button ; TUPLE: repeat-button < button ;
repeat-button H{ repeat-button H{
{ T{ drag } [ button-clicked ] } { T{ drag } [ button-clicked ] }
@ -95,8 +98,7 @@ repeat-button H{
: <repeat-button> ( label quot -- button ) : <repeat-button> ( label quot -- button )
#! Button that calls the quotation every 100ms as long as #! Button that calls the quotation every 100ms as long as
#! the mouse is held down. #! the mouse is held down.
repeat-button new repeat-button new-button bevel-button-theme ;
[ >r <bevel-button> r> set-gadget-delegate ] keep ;
TUPLE: checkmark-paint color ; TUPLE: checkmark-paint color ;
@ -128,20 +130,18 @@ M: checkmark-paint draw-interior
: toggle-model ( model -- ) : toggle-model ( model -- )
[ not ] change-model ; [ not ] change-model ;
: checkbox-theme ( gadget -- ) : checkbox-theme ( gadget -- gadget )
f >>interior f >>interior
{ 5 5 } >>gap { 5 5 } >>gap
1/2 >>align 1/2 >>align ; inline
drop ;
TUPLE: checkbox ; TUPLE: checkbox < button ;
: <checkbox> ( model label -- checkbox ) : <checkbox> ( model label -- checkbox )
<checkmark> <checkmark> label-on-right checkbox-theme
label-on-right [ model>> toggle-model ]
over [ toggle-model drop ] curry <button> checkbox new-button
checkbox construct-control swap >>model ;
dup checkbox-theme ;
M: checkbox model-changed M: checkbox model-changed
swap model-value over set-button-selected? relayout-1 ; swap model-value over set-button-selected? relayout-1 ;
@ -173,12 +173,13 @@ M: radio-paint draw-boundary
dup radio-knob-theme dup radio-knob-theme
{ 16 16 } over set-gadget-dim ; { 16 16 } over set-gadget-dim ;
TUPLE: radio-control value ; TUPLE: radio-control < button value ;
: <radio-control> ( value model gadget quot -- control ) : <radio-control> ( value model label -- control )
>r pick [ swap set-control-value ] curry r> call [ [ value>> ] keep set-control-value ]
radio-control construct-control radio-control new-button
tuck set-radio-control-value ; inline swap >>model
swap >>value ; inline
M: radio-control model-changed M: radio-control model-changed
swap model-value swap model-value
@ -190,15 +191,12 @@ M: radio-control model-changed
#! quot has stack effect ( value model label -- ) #! quot has stack effect ( value model label -- )
swapd [ swapd call gadget, ] 2curry assoc-each ; inline swapd [ swapd call gadget, ] 2curry assoc-each ; inline
: radio-button-theme ( gadget -- ) : radio-button-theme ( gadget -- gadget )
{ 5 5 } >>gap { 5 5 } >>gap
1/2 >>align 1/2 >>align ; inline
drop ;
: <radio-button> ( value model label -- gadget ) : <radio-button> ( value model label -- gadget )
<radio-knob> label-on-right <radio-knob> label-on-right radio-button-theme <radio-control> ;
[ <button> ] <radio-control>
dup radio-button-theme ;
: radio-buttons-theme ( gadget -- ) : radio-buttons-theme ( gadget -- )
{ 5 5 } >>gap drop ; { 5 5 } >>gap drop ;
@ -208,7 +206,7 @@ M: radio-control model-changed
dup radio-buttons-theme ; dup radio-buttons-theme ;
: <toggle-button> ( value model label -- gadget ) : <toggle-button> ( value model label -- gadget )
[ <bevel-button> ] <radio-control> ; <radio-control> bevel-button-theme ;
: <toggle-buttons> ( model assoc -- gadget ) : <toggle-buttons> ( model assoc -- gadget )
[ [ <toggle-button> ] <radio-controls> ] make-shelf ; [ [ <toggle-button> ] <radio-controls> ] make-shelf ;
@ -224,7 +222,7 @@ M: radio-control model-changed
: <toolbar> ( target -- toolbar ) : <toolbar> ( target -- toolbar )
[ [
"toolbar" over class command-map swap "toolbar" over class command-map commands>> swap
[ -rot <command-button> gadget, ] curry assoc-each [ -rot <command-button> gadget, ] curry assoc-each
] make-shelf ; ] make-shelf ;

4
extra/ui/gadgets/canvas/canvas.factor
View File

@ -5,10 +5,10 @@ ui.gadgets.worlds ui.render opengl opengl.gl kernel namespaces
classes.tuple colors ; classes.tuple colors ;
IN: ui.gadgets.canvas IN: ui.gadgets.canvas
TUPLE: canvas dlist ; TUPLE: canvas < gadget dlist ;
: <canvas> ( -- canvas ) : <canvas> ( -- canvas )
canvas construct-gadget canvas new-gadget
black solid-interior ; black solid-interior ;
: delete-canvas-dlist ( canvas -- ) : delete-canvas-dlist ( canvas -- )

9
extra/ui/gadgets/editors/editors-tests.factor
View File

@ -1,6 +1,7 @@
USING: ui.gadgets.editors tools.test kernel io io.streams.plain USING: accessors ui.gadgets.editors tools.test kernel io
definitions namespaces ui.gadgets ui.gadgets.grids prettyprint io.streams.plain definitions namespaces ui.gadgets
documents ui.gestures tools.test.ui models ; ui.gadgets.grids prettyprint documents ui.gestures tools.test.ui
models ;
[ "foo bar" ] [ [ "foo bar" ] [
<editor> "editor" set <editor> "editor" set
@ -44,5 +45,5 @@ documents ui.gestures tools.test.ui models ;
"hello" <model> <field> "field" set "hello" <model> <field> "field" set
"field" get [ "field" get [
[ "hello" ] [ "field" get field-model model-value ] unit-test [ "hello" ] [ "field" get field-model>> model-value ] unit-test
] with-grafted-gadget ] with-grafted-gadget

102
extra/ui/gadgets/editors/editors.factor
View File

@ -1,43 +1,38 @@
! Copyright (C) 2006, 2007 Slava Pestov ! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays documents ui.clipboards ui.commands ui.gadgets USING: accessors arrays documents io kernel math models
ui.gadgets.borders ui.gadgets.buttons ui.gadgets.labels namespaces opengl opengl.gl sequences strings io.styles
ui.gadgets.scrollers ui.gadgets.theme ui.render ui.gestures io math.vectors sorting colors combinators assocs math.order
kernel math models namespaces opengl opengl.gl sequences strings ui.clipboards ui.commands ui.gadgets ui.gadgets.borders
io.styles math.vectors sorting colors combinators assocs ui.gadgets.buttons ui.gadgets.labels ui.gadgets.scrollers
math.order ; ui.gadgets.theme ui.gadgets.wrappers ui.render ui.gestures ;
IN: ui.gadgets.editors IN: ui.gadgets.editors
TUPLE: editor TUPLE: editor < gadget
self
font color caret-color selection-color font color caret-color selection-color
caret mark caret mark
focused? ; focused? ;
: <loc> ( -- loc ) { 0 0 } <model> ; : <loc> ( -- loc ) { 0 0 } <model> ;
: init-editor-locs ( editor -- ) : init-editor-locs ( editor -- editor )
<loc> over set-editor-caret <loc> >>caret
<loc> swap set-editor-mark ; <loc> >>mark ; inline
: editor-theme ( editor -- ) : editor-theme ( editor -- editor )
black over set-editor-color black >>color
red over set-editor-caret-color red >>caret-color
selection-color over set-editor-selection-color selection-color >>selection-color
monospace-font swap set-editor-font ; monospace-font >>font ; inline
: new-editor ( class -- editor )
new-gadget
<document> >>model
init-editor-locs
editor-theme ; inline
: <editor> ( -- editor ) : <editor> ( -- editor )
<document> <gadget> editor construct-control editor new-editor ;
dup dup set-editor-self
dup init-editor-locs
dup editor-theme ;
: field-theme ( gadget -- )
gray <solid> swap set-gadget-boundary ;
: construct-editor ( object class -- tuple )
>r { set-gadget-delegate } r> construct
dup dup set-editor-self ; inline
: activate-editor-model ( editor model -- ) : activate-editor-model ( editor model -- )
2dup add-connection 2dup add-connection
@ -212,19 +207,19 @@ M: editor pref-dim*
dup editor-font* swap control-value text-dim ; dup editor-font* swap control-value text-dim ;
: contents-changed ( model editor -- ) : contents-changed ( model editor -- )
editor-self swap swap
over editor-caret [ over validate-loc ] (change-model) over caret>> [ over validate-loc ] (change-model)
over editor-mark [ over validate-loc ] (change-model) over mark>> [ over validate-loc ] (change-model)
drop relayout ; drop relayout ;
: caret/mark-changed ( model editor -- ) : caret/mark-changed ( model editor -- )
nip editor-self dup relayout-1 scroll>caret ; nip [ relayout-1 ] [ scroll>caret ] bi ;
M: editor model-changed M: editor model-changed
{ {
{ [ 2dup gadget-model eq? ] [ contents-changed ] } { [ 2dup model>> eq? ] [ contents-changed ] }
{ [ 2dup editor-caret eq? ] [ caret/mark-changed ] } { [ 2dup caret>> eq? ] [ caret/mark-changed ] }
{ [ 2dup editor-mark eq? ] [ caret/mark-changed ] } { [ 2dup mark>> eq? ] [ caret/mark-changed ] }
} cond ; } cond ;
M: editor gadget-selection? M: editor gadget-selection?
@ -474,10 +469,10 @@ editor "selection" f {
} define-command-map } define-command-map
! Multi-line editors ! Multi-line editors
TUPLE: multiline-editor ; TUPLE: multiline-editor < editor ;
: <multiline-editor> ( -- editor ) : <multiline-editor> ( -- editor )
<editor> multiline-editor construct-editor ; multiline-editor new-editor ;
multiline-editor "general" f { multiline-editor "general" f {
{ T{ key-down f f "RET" } insert-newline } { T{ key-down f f "RET" } insert-newline }
@ -485,33 +480,34 @@ multiline-editor "general" f {
{ T{ key-down f f "ENTER" } insert-newline } { T{ key-down f f "ENTER" } insert-newline }
} define-command-map } define-command-map
TUPLE: source-editor ; TUPLE: source-editor < editor ;
: <source-editor> ( -- editor ) : <source-editor> ( -- editor )
<multiline-editor> source-editor construct-editor ; source-editor new-editor ;
! Fields are like editors except they edit an external model ! Fields wrap an editor and edit an external model
TUPLE: field model editor ; TUPLE: field < wrapper field-model editor ;
: field-theme ( gadget -- gadget )
gray <solid> >>boundary ; inline
: <field-border> ( gadget -- border ) : <field-border> ( gadget -- border )
2 <border> 2 <border>
{ 1 0 } over set-border-fill { 1 0 } >>fill
dup field-theme ; field-theme ;
: <field> ( model -- gadget ) : <field> ( model -- gadget )
<editor> dup <field-border> <editor> dup <field-border> field new-wrapper
{ set-field-model set-field-editor set-gadget-delegate } swap >>editor
field construct ; swap >>field-model ;
M: field graft* M: field graft*
dup field-model model-value [ [ field-model>> model-value ] [ editor>> ] bi set-editor-string ]
over field-editor set-editor-string [ dup editor>> model>> add-connection ]
dup field-editor gadget-model add-connection ; bi ;
M: field ungraft* M: field ungraft*
dup field-editor gadget-model remove-connection ; dup editor>> model>> remove-connection ;
M: field model-changed M: field model-changed
nip nip [ editor>> editor-string ] [ field-model>> ] bi set-model ;
dup field-editor editor-string
swap field-model set-model ;

29
extra/ui/gadgets/frames/frames-docs.factor
View File

@ -2,6 +2,25 @@ USING: help.syntax help.markup ui.gadgets kernel arrays
quotations classes.tuple ui.gadgets.grids ; quotations classes.tuple ui.gadgets.grids ;
IN: ui.gadgets.frames IN: ui.gadgets.frames
ARTICLE: "ui-frame-layout" "Frame layouts"
"Frames resemble " { $link "ui-grid-layout" } " except the size of grid is fixed at 3x3, and the center gadget fills up any available space. Because frames delegate to grids, grid layout words can be used to add and remove children."
{ $subsection frame }
"Creating empty frames:"
{ $subsection <frame> }
"Creating new frames using a combinator:"
{ $subsection make-frame }
{ $subsection frame, }
"A set of mnemonic words for the positions on a frame's 3x3 grid; these words push values which may be passed to " { $link grid-add } " or " { $link frame, } ":"
{ $subsection @center }
{ $subsection @left }
{ $subsection @right }
{ $subsection @top }
{ $subsection @bottom }
{ $subsection @top-left }
{ $subsection @top-right }
{ $subsection @bottom-left }
{ $subsection @bottom-right } ;
: $ui-frame-constant ( element -- ) : $ui-frame-constant ( element -- )
drop drop
{ $description "Symbolic constant for a common input to " { $link grid-add } " and " { $link frame, } "." } print-element ; { $description "Symbolic constant for a common input to " { $link grid-add } " and " { $link frame, } "." } print-element ;
@ -25,18 +44,16 @@ HELP: <frame>
{ $values { "frame" frame } } { $values { "frame" frame } }
{ $description "Creates a new " { $link frame } " for laying out gadgets in a 3x3 grid." } ; { $description "Creates a new " { $link frame } " for laying out gadgets in a 3x3 grid." } ;
{ <frame> make-frame build-frame } related-words { <frame> make-frame } related-words
HELP: make-frame HELP: make-frame
{ $values { "quot" quotation } { "frame" frame } } { $values { "quot" quotation } { "frame" frame } }
{ $description "Creates a new frame. The quotation can add children by calling the " { $link frame, } " word." } ; { $description "Creates a new frame. The quotation can add children by calling the " { $link frame, } " word." } ;
HELP: build-frame
{ $values { "tuple" tuple } { "quot" quotation } }
{ $description "Creates a new frame and sets " { $snippet "tuple" } "'s delegate to the new frame. The quotation can add children by calling the " { $link frame, } " word, and access the frame by calling " { $link g } " or " { $link g-> } "." } ;
HELP: frame, HELP: frame,
{ $values { "gadget" gadget } { "i" "non-negative integer" } { "j" "non-negative integer" } } { $values { "gadget" gadget } { "i" "non-negative integer" } { "j" "non-negative integer" } }
{ $description "Adds a child gadget at the specified location. This word can only be called inside the quotation passed to " { $link make-frame } " or " { $link build-frame } "." } ; { $description "Adds a child gadget at the specified location. This word can only be called inside the quotation passed to " { $link make-frame } "." } ;
{ grid frame } related-words { grid frame } related-words
ABOUT: "ui-frame-layout"

11
extra/ui/gadgets/frames/frames.factor
View File

@ -6,7 +6,7 @@ IN: ui.gadgets.frames
! A frame arranges gadgets in a 3x3 grid, where the center ! A frame arranges gadgets in a 3x3 grid, where the center
! gadgets gets left-over space. ! gadgets gets left-over space.
TUPLE: frame ; TUPLE: frame < grid ;
: <frame-grid> ( -- grid ) 9 [ <gadget> ] replicate 3 group ; : <frame-grid> ( -- grid ) 9 [ <gadget> ] replicate 3 group ;
@ -21,9 +21,11 @@ TUPLE: frame ;
: @bottom-left 0 2 ; : @bottom-left 0 2 ;
: @bottom-right 2 2 ; : @bottom-right 2 2 ;
: new-frame ( class -- frame )
<frame-grid> swap new-grid ; inline
: <frame> ( -- frame ) : <frame> ( -- frame )
frame new frame new-frame ;
<frame-grid> <grid> over set-gadget-delegate ;
: (fill-center) ( vec n -- ) : (fill-center) ( vec n -- )
over first pick third v+ [v-] 1 rot set-nth ; over first pick third v+ [v-] 1 rot set-nth ;
@ -39,8 +41,5 @@ M: frame layout*
: make-frame ( quot -- frame ) : make-frame ( quot -- frame )
<frame> make-gadget ; inline <frame> make-gadget ; inline
: build-frame ( tuple quot -- tuple )
<frame> build-gadget ; inline
: frame, ( gadget i j -- ) : frame, ( gadget i j -- )
\ make-gadget get -rot grid-add ; \ make-gadget get -rot grid-add ;

49
extra/ui/gadgets/gadgets-docs.factor
View File

@ -65,8 +65,6 @@ HELP: <gadget>
{ $values { "gadget" "a new " { $link gadget } } } { $values { "gadget" "a new " { $link gadget } } }
{ $description "Creates a new gadget." } ; { $description "Creates a new gadget." } ;
{ <gadget> set-gadget-delegate } related-words
HELP: relative-loc HELP: relative-loc
{ $values { "fromgadget" gadget } { "togadget" gadget } { "loc" "a pair of integers" } } { $values { "fromgadget" gadget } { "togadget" gadget } { "loc" "a pair of integers" } }
{ $description { $description
@ -99,11 +97,6 @@ HELP: each-child
{ $values { "gadget" gadget } { "quot" "a quotation with stack effect " { $snippet "( child -- )" } } } { $values { "gadget" gadget } { "quot" "a quotation with stack effect " { $snippet "( child -- )" } } }
{ $description "Applies the quotation to each child of the gadget." } ; { $description "Applies the quotation to each child of the gadget." } ;
HELP: set-gadget-delegate
{ $values { "gadget" gadget } { "tuple" tuple } }
{ $description "Sets the delegate of " { $snippet "tuple" } " to " { $snippet "gadget" } ". This is like " { $link set-delegate } ", except that to ensure correct behavior, the parent of each child of " { $snippet "gadget" } " is changed to " { $snippet "tuple" } "." }
{ $notes "This word should be used instead of " { $link set-delegate } " when setting a tuple's delegate to a gadget." } ;
HELP: gadget-selection? HELP: gadget-selection?
{ $values { "gadget" gadget } { "?" "a boolean" } } { $values { "gadget" gadget } { "?" "a boolean" } }
{ $contract "Outputs if the gadget has an active text selection; if so, the selected text can be obtained with a call to " { $link gadget-selection } "." } ; { $contract "Outputs if the gadget has an active text selection; if so, the selected text can be obtained with a call to " { $link gadget-selection } "." } ;
@ -239,55 +232,25 @@ HELP: focusable-child
HELP: gadget, HELP: gadget,
{ $values { "gadget" gadget } } { $values { "gadget" gadget } }
{ $description "Adds a new child to the gadget being constructed. This word can only be used from a quotation passed to " { $link make-gadget } " or " { $link build-gadget } "." } ; { $description "Adds a new child to the gadget being constructed. This word can only be used from a quotation passed to " { $link make-gadget } "." } ;
HELP: make-gadget HELP: make-gadget
{ $values { "quot" quotation } { "gadget" gadget } } { $values { "quot" quotation } { "gadget" gadget } }
{ $description "Calls the quotation in a new scope with the gadget stored in the " { $link make-gadget } " variable." } ; { $description "Calls the quotation in a new scope with the gadget stored in the " { $link make-gadget } " variable." } ;
HELP: build-gadget
{ $values { "tuple" tuple } { "quot" quotation } { "gadget" gadget } }
{ $description "Delegates the tuple to the gadget, and calls the quotation in a new scope with the tuple stored in the " { $link make-gadget } " and " { $link gadget } " variables." } ;
HELP: with-gadget HELP: with-gadget
{ $values { "gadget" gadget } { "quot" quotation } } { $values { "gadget" gadget } { "quot" quotation } }
{ $description "Calls the quotation in a new scope with the " { $link gadget } " and " { $link make-gadget } " variables set to " { $snippet "gadget" } ". The quotation can call " { $link g } " and " { $link g-> } " to access the gadget." } ; { $description "Calls the quotation in a new scope with the " { $link gadget } " and " { $link make-gadget } " variables set to " { $snippet "gadget" } ". The quotation can call " { $link g } " and " { $link g-> } " to access the gadget." } ;
HELP: g HELP: g
{ $values { "gadget" gadget } } { $values { "gadget" gadget } }
{ $description "Outputs the gadget being built. Can only be used inside a quotation passed to " { $link build-gadget } "." } ; { $description "Outputs the gadget being built. Can only be used inside a quotation passed to " { $link with-gadget } "." } ;
HELP: g-> HELP: g->
{ $values { "x" object } { "gadget" gadget } } { $values { "x" object } { "gadget" gadget } }
{ $description "Duplicates the top of the stack and outputs the gadget being built. Can only be used inside a quotation passed to " { $link build-gadget } "." } ; { $description "Duplicates the top of the stack and outputs the gadget being built. Can only be used inside a quotation passed to " { $link with-gadget } "." } ;
HELP: construct-control { control-value set-control-value gadget-model } related-words
{ $values { "model" model } { "gadget" gadget } { "class" class } { "control" gadget } }
{ $description "Creates a new control linked to the given model. The gadget parameter becomes the control's delegate. The quotation is called when the model value changes." }
{ $examples
"The following example creates a gadget whose fill color is determined by the value of a model:"
{ $code
"USING: ui.gadgets ui.gadgets.panes models ;"
": set-fill-color >r <solid> r> set-gadget-interior ;"
""
"TUPLE: color-gadget ;"
""
"M: color-gadget model-changed"
" >r model-value r> set-fill-color ;"
""
": <color-gadget> ( model -- gadget )"
" <gadget>"
" { 100 100 } over set-rect-dim"
" color-gadget"
" construct-control ;"
""
"{ 1.0 0.0 0.5 1.0 } <model> <color-gadget>"
"gadget."
}
"The " { $vocab-link "color-picker" } " module extends this example into a more elaborate color chooser."
} ;
{ construct-control control-value set-control-value gadget-model } related-words
HELP: control-value HELP: control-value
{ $values { "control" gadget } { "value" object } } { $values { "control" gadget } { "value" object } }
@ -298,10 +261,8 @@ HELP: set-control-value
{ $description "Sets the value of the control's model." } ; { $description "Sets the value of the control's model." } ;
ARTICLE: "ui-control-impl" "Implementing controls" ARTICLE: "ui-control-impl" "Implementing controls"
"A " { $emphasis "control" } " is a gadget which is linked to an underlying " { $link model } " by having its " { $link gadget-model } " slot set to a model instance." "A " { $emphasis "control" } " is a gadget which is linked to an underlying " { $link model } " by having its " { $link gadget-model } " slot set to a " { $link model } " instance."
$nl $nl
"To implement a new control, simply use this word in your constructor:"
{ $subsection construct-control }
"Some utility words useful in control implementations:" "Some utility words useful in control implementations:"
{ $subsection gadget-model } { $subsection gadget-model }
{ $subsection control-value } { $subsection control-value }

9
extra/ui/gadgets/gadgets-tests.factor
View File

@ -36,13 +36,6 @@ prettyprint io.streams.string ;
intersects? intersects?
] unit-test ] unit-test
TUPLE: fooey ;
C: <fooey> fooey
[ ] [ <gadget> <fooey> set-gadget-delegate ] unit-test
[ ] [ f <fooey> set-gadget-delegate ] unit-test
[ { 300 300 } ] [ { 300 300 } ]
[ [
! c contains b contains a ! c contains b contains a
@ -113,7 +106,7 @@ C: <fooey> fooey
TUPLE: mock-gadget graft-called ungraft-called ; TUPLE: mock-gadget graft-called ungraft-called ;
: <mock-gadget> : <mock-gadget> ( -- gadget )
0 0 mock-gadget boa <gadget> over set-delegate ; 0 0 mock-gadget boa <gadget> over set-delegate ;
M: mock-gadget graft* M: mock-gadget graft*

43
extra/ui/gadgets/gadgets.factor
View File

@ -9,7 +9,9 @@ SYMBOL: ui-notify-flag
: notify-ui-thread ( -- ) ui-notify-flag get-global raise-flag ; : notify-ui-thread ( -- ) ui-notify-flag get-global raise-flag ;
TUPLE: rect loc dim ; TUPLE: rect { loc initial: { 0 0 } } { dim initial: { 0 0 } } ;
: <zero-rect> ( -- rect ) rect new ;
C: <rect> rect C: <rect> rect
@ -44,12 +46,14 @@ M: array rect-dim drop { 0 0 } ;
: rect-union ( rect1 rect2 -- newrect ) : rect-union ( rect1 rect2 -- newrect )
(rect-union) <extent-rect> ; (rect-union) <extent-rect> ;
TUPLE: gadget < identity-tuple TUPLE: gadget < rect
pref-dim parent children orientation focus pref-dim parent children orientation focus
visible? root? clipped? layout-state graft-state graft-node visible? root? clipped? layout-state graft-state graft-node
interior boundary interior boundary
model ; model ;
M: gadget equal? 2drop f ;
M: gadget hashcode* drop gadget hashcode* ; M: gadget hashcode* drop gadget hashcode* ;
M: gadget model-changed 2drop ; M: gadget model-changed 2drop ;
@ -58,18 +62,14 @@ M: gadget model-changed 2drop ;
: nth-gadget ( n gadget -- child ) gadget-children nth ; : nth-gadget ( n gadget -- child ) gadget-children nth ;
: <zero-rect> ( -- rect ) { 0 0 } dup <rect> ; : new-gadget ( class -- gadget )
new
{ 0 1 } >>orientation
t >>visible?
{ f f } >>graft-state ; inline
: <gadget> ( -- gadget ) : <gadget> ( -- gadget )
<zero-rect> { 0 1 } t { f f } { gadget new-gadget ;
set-delegate
set-gadget-orientation
set-gadget-visible?
set-gadget-graft-state
} gadget construct ;
: construct-gadget ( class -- tuple )
>r <gadget> r> construct-delegate ; inline
: activate-control ( gadget -- ) : activate-control ( gadget -- )
dup gadget-model dup [ dup gadget-model dup [
@ -137,15 +137,6 @@ M: gadget children-on nip gadget-children ;
: each-child ( gadget quot -- ) : each-child ( gadget quot -- )
>r gadget-children r> each ; inline >r gadget-children r> each ; inline
: set-gadget-delegate ( gadget tuple -- )
over [
dup pick [ set-gadget-parent ] with each-child
] when set-delegate ;
: construct-control ( model gadget class -- control )
>r tuck set-gadget-model
{ set-gadget-delegate } r> construct ; inline
! Selection protocol ! Selection protocol
GENERIC: gadget-selection? ( gadget -- ? ) GENERIC: gadget-selection? ( gadget -- ? )
@ -414,5 +405,11 @@ M: f request-focus-on 2drop ;
swap dup \ make-gadget set gadget set call swap dup \ make-gadget set gadget set call
] with-scope ; inline ] with-scope ; inline
: build-gadget ( tuple quot gadget -- tuple ) ! Deprecated
pick set-gadget-delegate over >r with-gadget r> ; inline : set-gadget-delegate ( gadget tuple -- )
over [
dup pick [ set-gadget-parent ] with each-child
] when set-delegate ;
: construct-gadget ( class -- tuple )
>r <gadget> { set-delegate } r> construct ; inline

12
extra/ui/gadgets/grids/grids-docs.factor
View File

@ -1,6 +1,16 @@
USING: ui.gadgets help.markup help.syntax arrays ; USING: ui.gadgets help.markup help.syntax arrays ;
IN: ui.gadgets.grids IN: ui.gadgets.grids
ARTICLE: "ui-grid-layout" "Grid layouts"
"Grid gadgets layout their children in a rectangular grid."
{ $subsection grid }
"Creating grids from a fixed set of gadgets:"
{ $subsection <grid> }
"Managing chidren:"
{ $subsection grid-add }
{ $subsection grid-remove }
{ $subsection grid-child } ;
HELP: grid HELP: grid
{ $class-description "A grid gadget lays out its children so that all gadgets in a column have equal width and all gadgets in a row have equal height." { $class-description "A grid gadget lays out its children so that all gadgets in a column have equal width and all gadgets in a row have equal height."
$nl $nl
@ -30,3 +40,5 @@ HELP: grid-remove
{ $values { "grid" grid } { "i" "non-negative integer" } { "j" "non-negative integer" } } { $values { "grid" grid } { "i" "non-negative integer" } { "j" "non-negative integer" } }
{ $description "Removes a child gadget from the specified location." } { $description "Removes a child gadget from the specified location." }
{ $side-effects "grid" } ; { $side-effects "grid" } ;
ABOUT: "ui-grid-layout"

34
extra/ui/gadgets/grids/grids.factor
View File

@ -1,31 +1,33 @@
! Copyright (C) 2006 Slava Pestov. ! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math namespaces sequences words io USING: arrays kernel math namespaces sequences words io
io.streams.string math.vectors ui.gadgets columns ; io.streams.string math.vectors ui.gadgets columns accessors ;
IN: ui.gadgets.grids IN: ui.gadgets.grids
TUPLE: grid children gap fill? ; TUPLE: grid < gadget
grid
{ gap initial: { 0 0 } }
{ fill? initial: t } ;
: set-grid-children* ( children grid -- ) : new-grid ( children class -- grid )
[ set-grid-children ] 2keep >r concat r> add-gadgets ; new-gadget
[ (>>grid) ] [ >r concat r> add-gadgets ] [ nip ] 2tri ;
inline
: <grid> ( children -- grid ) : <grid> ( children -- grid )
grid construct-gadget grid new-grid ;
[ set-grid-children* ] keep
{ 0 0 } over set-grid-gap
t over set-grid-fill? ;
: grid-child ( grid i j -- gadget ) rot grid-children nth nth ; : grid-child ( grid i j -- gadget ) rot grid>> nth nth ;
: grid-add ( gadget grid i j -- ) : grid-add ( gadget grid i j -- )
>r >r 2dup add-gadget r> r> >r >r 2dup add-gadget r> r>
3dup grid-child unparent rot grid-children nth set-nth ; 3dup grid-child unparent rot grid>> nth set-nth ;
: grid-remove ( grid i j -- ) : grid-remove ( grid i j -- )
>r >r >r <gadget> r> r> r> grid-add ; >r >r >r <gadget> r> r> r> grid-add ;
: pref-dim-grid ( grid -- dims ) : pref-dim-grid ( grid -- dims )
grid-children [ [ pref-dim ] map ] map ; grid>> [ [ pref-dim ] map ] map ;
: (compute-grid) ( grid -- seq ) [ max-dim ] map ; : (compute-grid) ( grid -- seq ) [ max-dim ] map ;
@ -49,7 +51,7 @@ M: grid pref-dim*
gap-sum >r gap-sum r> (pair-up) ; gap-sum >r gap-sum r> (pair-up) ;
: do-grid ( dims grid quot -- ) : do-grid ( dims grid quot -- )
-rot grid-children -rot grid>>
[ [ pick call ] 2each ] 2each [ [ pick call ] 2each ] 2each
drop ; inline drop ; inline
@ -65,7 +67,7 @@ M: grid pref-dim*
pick grid-fill? [ pick grid-fill? [
pair-up swap [ set-layout-dim ] do-grid pair-up swap [ set-layout-dim ] do-grid
] [ ] [
2drop grid-children [ [ prefer ] each ] each 2drop grid>> [ [ prefer ] each ] each
] if ; ] if ;
: grid-layout ( grid horiz vert -- ) : grid-layout ( grid horiz vert -- )
@ -77,12 +79,12 @@ M: grid children-on ( rect gadget -- seq )
dup gadget-children empty? [ dup gadget-children empty? [
2drop f 2drop f
] [ ] [
{ 0 1 } swap grid-children { 0 1 } swap grid>>
[ 0 <column> fast-children-on ] keep [ 0 <column> fast-children-on ] keep
<slice> concat <slice> concat
] if ; ] if ;
M: grid gadget-text* M: grid gadget-text*
grid-children grid>>
[ [ gadget-text ] map ] map format-table [ [ gadget-text ] map ] map format-table
[ CHAR: \n , ] [ % ] interleave ; [ CHAR: \n , ] [ % ] interleave ;

17
extra/ui/gadgets/incremental/incremental-docs.factor
View File

@ -25,3 +25,20 @@ HELP: clear-incremental
{ $values { "incremental" incremental } } { $values { "incremental" incremental } }
{ $description "Removes all gadgets from the incremental layout and performs relayout immediately in constant time." } { $description "Removes all gadgets from the incremental layout and performs relayout immediately in constant time." }
{ $side-effects "incremental" } ; { $side-effects "incremental" } ;
ARTICLE: "ui-incremental-layout" "Incremental layouts"
"Incremental layout gadgets are like " { $link "ui-pack-layout" } " except the relayout operation after adding a new child can be done in constant time."
$nl
"With all layouts, relayout requests from consecutive additions and removals are of children are coalesced and result in only one relayout operation being performed, however the run time of the relayout operation itself depends on the number of children."
$nl
"Incremental layout is used by " { $link "ui.gadgets.panes" } " to ensure that new lines of output does not take longer to display when the pane already has previous output."
$nl
"Incremental layouts are not a general replacement for " { $link "ui-pack-layout" } " and there are some limitations to be aware of."
{ $subsection incremental }
{ $subsection <incremental> }
"Children are added and removed with a special set of words which perform necessary relayout immediately:"
{ $subsection add-incremental }
{ $subsection clear-incremental }
"Calling " { $link unparent } " to remove a child of an incremental layout is permitted, however the relayout following the removal will not be performed in constant time, because all gadgets following the removed gadget need to be moved." ;
ABOUT: "ui-incremental-layout"

17
extra/ui/gadgets/incremental/incremental.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2005, 2007 Slava Pestov. ! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: io kernel math namespaces math.vectors ui.gadgets ; USING: io kernel math namespaces math.vectors ui.gadgets
ui.gadgets.packs accessors ;
IN: ui.gadgets.incremental IN: ui.gadgets.incremental
! Incremental layout allows adding lines to panes to be O(1). ! Incremental layout allows adding lines to panes to be O(1).
@ -14,16 +15,16 @@ IN: ui.gadgets.incremental
! New gadgets are added at ! New gadgets are added at
! incremental-cursor gadget-orientation v* ! incremental-cursor gadget-orientation v*
TUPLE: incremental cursor ; TUPLE: incremental < pack cursor ;
: <incremental> ( pack -- incremental ) : <incremental> ( -- incremental )
dup pref-dim incremental new-gadget
{ set-gadget-delegate set-incremental-cursor } { 0 1 } >>orientation
incremental construct ; { 0 0 } >>cursor ;
M: incremental pref-dim* M: incremental pref-dim*
dup gadget-layout-state [ dup gadget-layout-state [
dup delegate pref-dim over set-incremental-cursor dup call-next-method over set-incremental-cursor
] when incremental-cursor ; ] when incremental-cursor ;
: next-cursor ( gadget incremental -- cursor ) : next-cursor ( gadget incremental -- cursor )

27
extra/ui/gadgets/labelled/labelled-tests.factor
View File

@ -1,27 +0,0 @@
USING: ui.gadgets ui.gadgets.labels ui.gadgets.labelled
ui.gadgets.packs ui.gadgets.frames ui.gadgets.grids namespaces
kernel tools.test ui.gadgets.buttons sequences ;
IN: ui.gadgets.labelled.tests
TUPLE: testing ;
[ ] [
T{ testing } [ "Hey" <label> ] "Testing"
build-closable-gadget "g" set
] unit-test
[ t ] [ "g" get testing? ] unit-test
[ t ] [ "g" get delegate closable-gadget? ] unit-test
[ t ] [ "g" get closable-gadget-content label? ] unit-test
[ ] [
<pile> "p" set
"g" get "p" get add-gadget
"g" get @top grid-child @left grid-child
dup button-quot call
] unit-test
[ f ] [ "g" get "p" get gadget-children memq? ] unit-test

29
extra/ui/gadgets/labelled/labelled.factor
View File

@ -8,14 +8,16 @@ sequences sequences words classes.tuple ui.gadgets ui.render
colors ; colors ;
IN: ui.gadgets.labelled IN: ui.gadgets.labelled
TUPLE: labelled-gadget content ; TUPLE: labelled-gadget < track content ;
: <labelled-gadget> ( gadget title -- newgadget ) : <labelled-gadget> ( gadget title -- newgadget )
labelled-gadget new { 0 1 } labelled-gadget new-track
[ [
<label> reverse-video-theme f track, [
g-> set-labelled-gadget-content 1 track, <label> reverse-video-theme f track,
] { 0 1 } build-track ; g-> set-labelled-gadget-content 1 track,
] with-gadget
] keep ;
M: labelled-gadget focusable-child* labelled-gadget-content ; M: labelled-gadget focusable-child* labelled-gadget-content ;
@ -44,21 +46,18 @@ M: labelled-gadget focusable-child* labelled-gadget-content ;
<title-label> @center frame, <title-label> @center frame,
] make-frame ; ] make-frame ;
TUPLE: closable-gadget content ; TUPLE: closable-gadget < frame content ;
: find-closable-gadget ( parent -- child ) : find-closable-gadget ( parent -- child )
[ [ closable-gadget? ] is? ] find-parent ; [ [ closable-gadget? ] is? ] find-parent ;
: <closable-gadget> ( gadget title quot -- gadget ) : <closable-gadget> ( gadget title quot -- gadget )
closable-gadget new closable-gadget new-frame
[ [
<title-bar> @top frame, [
g-> set-closable-gadget-content @center frame, <title-bar> @top frame,
] build-frame ; g-> set-closable-gadget-content @center frame,
] with-gadget
] keep ;
M: closable-gadget focusable-child* closable-gadget-content ; M: closable-gadget focusable-child* closable-gadget-content ;
: build-closable-gadget ( tuple quot title -- tuple )
pick >r >r with-gadget
r> [ find-closable-gadget unparent ] <closable-gadget> r>
[ set-gadget-delegate ] keep ; inline

18
extra/ui/gadgets/labels/labels.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2005, 2007 Slava Pestov. ! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays hashtables io kernel math namespaces USING: accessors arrays hashtables io kernel math namespaces
opengl sequences strings splitting opengl sequences strings splitting
@ -7,7 +7,7 @@ models ;
IN: ui.gadgets.labels IN: ui.gadgets.labels
! A label gadget draws a string. ! A label gadget draws a string.
TUPLE: label text font color ; TUPLE: label < gadget text font color ;
: label-string ( label -- string ) : label-string ( label -- string )
text>> dup string? [ "\n" join ] unless ; inline text>> dup string? [ "\n" join ] unless ; inline
@ -23,10 +23,13 @@ TUPLE: label text font color ;
sans-serif-font >>font sans-serif-font >>font
black >>color ; inline black >>color ; inline
: <label> ( string -- label ) : new-label ( string class -- label )
label construct-gadget new-gadget
[ set-label-string ] keep [ set-label-string ] keep
label-theme ; label-theme ; inline
: <label> ( string -- label )
label new-label ;
M: label pref-dim* M: label pref-dim*
[ font>> open-font ] [ text>> ] bi text-dim ; [ font>> open-font ] [ text>> ] bi text-dim ;
@ -37,13 +40,14 @@ M: label draw-gadget*
M: label gadget-text* label-string % ; M: label gadget-text* label-string % ;
TUPLE: label-control ; TUPLE: label-control < label ;
M: label-control model-changed M: label-control model-changed
swap model-value over set-label-string relayout ; swap model-value over set-label-string relayout ;
: <label-control> ( model -- gadget ) : <label-control> ( model -- gadget )
"" <label> label-control construct-control ; "" label-control new-label
swap >>model ;
: text-theme ( gadget -- gadget ) : text-theme ( gadget -- gadget )
black >>color black >>color

27
extra/ui/gadgets/lists/lists.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2006, 2007 Slava Pestov. ! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors ui.commands ui.gestures ui.render ui.gadgets USING: accessors ui.commands ui.gestures ui.render ui.gadgets
ui.gadgets.labels ui.gadgets.scrollers ui.gadgets.labels ui.gadgets.scrollers
@ -7,17 +7,20 @@ ui.gadgets.presentations ui.gadgets.viewports ui.gadgets.packs
math.vectors classes.tuple ; math.vectors classes.tuple ;
IN: ui.gadgets.lists IN: ui.gadgets.lists
TUPLE: list index presenter color hook ; TUPLE: list < pack index presenter color hook ;
: list-theme ( list -- ) : list-theme ( list -- list )
{ 0.8 0.8 1.0 1.0 } swap set-list-color ; { 0.8 0.8 1.0 1.0 } >>color ; inline
: <list> ( hook presenter model -- gadget ) : <list> ( hook presenter model -- gadget )
<filled-pile> list construct-control list new-gadget
[ set-list-presenter ] keep { 0 1 } >>orientation
[ set-list-hook ] keep 1 >>fill
0 over set-list-index 0 >>index
dup list-theme ; swap >>model
swap >>presenter
swap >>hook
list-theme ;
: calc-bounded-index ( n list -- m ) : calc-bounded-index ( n list -- m )
control-value length 1- min 0 max ; control-value length 1- min 0 max ;
@ -30,9 +33,9 @@ TUPLE: list index presenter color hook ;
hook>> [ [ [ list? ] is? ] find-parent ] prepend ; hook>> [ [ [ list? ] is? ] find-parent ] prepend ;
: <list-presentation> ( hook elt presenter -- gadget ) : <list-presentation> ( hook elt presenter -- gadget )
keep <presentation> keep >r >label text-theme r>
swap >>hook <presentation>
text-theme ; inline swap >>hook ; inline
: <list-items> ( list -- seq ) : <list-items> ( list -- seq )
[ list-presentation-hook ] [ list-presentation-hook ]

4
extra/ui/gadgets/menus/menus.factor
View File

@ -9,10 +9,10 @@ IN: ui.gadgets.menus
: menu-loc ( world menu -- loc ) : menu-loc ( world menu -- loc )
>r rect-dim r> pref-dim [v-] hand-loc get-global vmin ; >r rect-dim r> pref-dim [v-] hand-loc get-global vmin ;
TUPLE: menu-glass ; TUPLE: menu-glass < gadget ;
: <menu-glass> ( menu world -- glass ) : <menu-glass> ( menu world -- glass )
menu-glass construct-gadget menu-glass new-gadget
>r over menu-loc over set-rect-loc r> >r over menu-loc over set-rect-loc r>
[ add-gadget ] keep ; [ add-gadget ] keep ;

18
extra/ui/gadgets/packs/packs-docs.factor
View File

@ -2,6 +2,22 @@ USING: ui.gadgets help.markup help.syntax generic kernel
classes.tuple quotations ; classes.tuple quotations ;
IN: ui.gadgets.packs IN: ui.gadgets.packs
ARTICLE: "ui-pack-layout" "Pack layouts"
"Pack gadgets layout their children along a single axis."
{ $subsection pack }
"Creating empty packs:"
{ $subsection <pack> }
{ $subsection <pile> }
{ $subsection <shelf> }
"Creating packs using a combinator:"
{ $subsection make-pile }
{ $subsection make-filled-pile }
{ $subsection make-shelf }
{ $subsection gadget, }
"For more control, custom layouts can reuse portions of pack layout logic:"
{ $subsection pack-pref-dim }
{ $subsection pack-layout } ;
HELP: pack HELP: pack
{ $class-description "A gadget which lays out its children along a single axis stored in the " { $link gadget-orientation } " slot. Can be constructed with one of the following words:" { $class-description "A gadget which lays out its children along a single axis stored in the " { $link gadget-orientation } " slot. Can be constructed with one of the following words:"
{ $list { $list
@ -59,3 +75,5 @@ HELP: make-filled-pile
HELP: make-shelf HELP: make-shelf
{ $values { "quot" quotation } { "pack" "a new " { $link pack } } } { $values { "quot" quotation } { "pack" "a new " { $link pack } } }
{ $description "Creates a new " { $link pack } " which lays out a sequence of gadgets horizontally. The quotation can add children by calling the " { $link gadget, } " word." } ; { $description "Creates a new " { $link pack } " which lays out a sequence of gadgets horizontally. The quotation can add children by calling the " { $link gadget, } " word." } ;
ABOUT: "ui-pack-layout"

22
extra/ui/gadgets/packs/packs.factor
View File

@ -1,10 +1,13 @@
! Copyright (C) 2005, 2007 Slava Pestov. ! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: sequences ui.gadgets kernel math math.functions USING: sequences ui.gadgets kernel math math.functions
math.vectors namespaces math.order ; math.vectors namespaces math.order accessors ;
IN: ui.gadgets.packs IN: ui.gadgets.packs
TUPLE: pack align fill gap ; TUPLE: pack < gadget
{ align initial: 0 }
{ fill initial: 0 }
{ gap initial: { 0 0 } } ;
: packed-dim-2 ( gadget sizes -- list ) : packed-dim-2 ( gadget sizes -- list )
[ over rect-dim over v- rot pack-fill v*n v+ ] with map ; [ over rect-dim over v- rot pack-fill v*n v+ ] with map ;
@ -32,13 +35,8 @@ TUPLE: pack align fill gap ;
>r packed-locs r> [ set-rect-loc ] 2each ; >r packed-locs r> [ set-rect-loc ] 2each ;
: <pack> ( orientation -- pack ) : <pack> ( orientation -- pack )
0 0 { 0 0 } <gadget> { pack new-gadget
set-gadget-orientation swap >>orientation ;
set-pack-align
set-pack-fill
set-pack-gap
set-delegate
} pack construct ;
: <pile> ( -- pack ) { 0 1 } <pack> ; : <pile> ( -- pack ) { 0 1 } <pack> ;
@ -71,7 +69,3 @@ M: pack children-on ( rect gadget -- seq )
: make-shelf ( quot -- pack ) : make-shelf ( quot -- pack )
<shelf> make-gadget ; inline <shelf> make-gadget ; inline
: build-pack ( quot quot orientation -- pack )
<pack> build-gadget ; inline

68
extra/ui/gadgets/panes/panes.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2005, 2007 Slava Pestov. ! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays ui.gadgets ui.gadgets.borders ui.gadgets.buttons USING: arrays ui.gadgets ui.gadgets.borders ui.gadgets.buttons
ui.gadgets.labels ui.gadgets.scrollers ui.gadgets.labels ui.gadgets.scrollers
@ -12,7 +12,8 @@ ui.gadgets.grid-lines classes.tuple models continuations
destructors accessors ; destructors accessors ;
IN: ui.gadgets.panes IN: ui.gadgets.panes
TUPLE: pane output current prototype scrolls? TUPLE: pane < pack
output current prototype scrolls?
selection-color caret mark selecting? ; selection-color caret mark selecting? ;
: clear-selection ( pane -- ) : clear-selection ( pane -- )
@ -47,16 +48,19 @@ M: pane gadget-selection
[ pane-current clear-gadget ] [ pane-current clear-gadget ]
tri ; tri ;
: pane-theme ( pane -- ) : pane-theme ( pane -- pane )
selection-color >>selection-color drop ; selection-color >>selection-color ; inline
: new-pane ( class -- pane )
new-gadget
{ 0 1 } >>orientation
<shelf> >>prototype
<incremental> over add-output
dup prepare-line
pane-theme ;
: <pane> ( -- pane ) : <pane> ( -- pane )
pane new pane new-pane ;
<pile> over set-delegate
<shelf> >>prototype
<pile> <incremental> over add-output
dup prepare-line
dup pane-theme ;
GENERIC: draw-selection ( loc obj -- ) GENERIC: draw-selection ( loc obj -- )
@ -142,14 +146,15 @@ M: style-stream write-gadget
: <scrolling-pane> ( -- pane ) : <scrolling-pane> ( -- pane )
<pane> t over set-pane-scrolls? ; <pane> t over set-pane-scrolls? ;
TUPLE: pane-control quot ; TUPLE: pane-control < pane quot ;
M: pane-control model-changed M: pane-control model-changed
swap model-value swap dup pane-control-quot with-pane ; swap model-value swap dup pane-control-quot with-pane ;
: <pane-control> ( model quot -- pane ) : <pane-control> ( model quot -- pane )
>r <pane> pane-control construct-control r> pane-control new-pane
over set-pane-control-quot ; swap >>quot
swap >>model ;
: do-pane-stream ( pane-stream quot -- ) : do-pane-stream ( pane-stream quot -- )
>r pane-stream-pane r> keep scroll-pane ; inline >r pane-stream-pane r> keep scroll-pane ; inline
@ -195,13 +200,15 @@ M: pane-stream make-span-stream
: apply-presentation-style ( style gadget -- style gadget ) : apply-presentation-style ( style gadget -- style gadget )
presented [ <presentation> ] apply-style ; presented [ <presentation> ] apply-style ;
: <styled-label> ( style text -- gadget ) : style-label ( style gadget -- gadget )
<label>
apply-foreground-style apply-foreground-style
apply-background-style apply-background-style
apply-font-style apply-font-style
apply-presentation-style apply-presentation-style
nip ; nip ; inline
: <styled-label> ( style text -- gadget )
<label> style-label ;
! Paragraph styles ! Paragraph styles
@ -235,28 +242,27 @@ M: pane-stream make-span-stream
apply-printer-style apply-printer-style
nip ; nip ;
TUPLE: nested-pane-stream style parent ; TUPLE: nested-pane-stream < pane-stream style parent ;
: <nested-pane-stream> ( style parent -- stream ) : new-nested-pane-stream ( style parent class -- stream )
>r <pane> apply-wrap-style <pane-stream> r> { new
set-nested-pane-stream-style swap >>parent
set-delegate swap <pane> apply-wrap-style [ >>style ] [ >>pane ] bi* ;
set-nested-pane-stream-parent inline
} nested-pane-stream construct ;
: unnest-pane-stream ( stream -- child parent ) : unnest-pane-stream ( stream -- child parent )
dup ?nl dup ?nl
dup nested-pane-stream-style dup style>>
over pane-stream-pane smash-pane style-pane over pane>> smash-pane style-pane
swap nested-pane-stream-parent ; swap parent>> ;
TUPLE: pane-block-stream ; TUPLE: pane-block-stream < nested-pane-stream ;
M: pane-block-stream dispose M: pane-block-stream dispose
unnest-pane-stream write-gadget ; unnest-pane-stream write-gadget ;
M: pane-stream make-block-stream M: pane-stream make-block-stream
<nested-pane-stream> pane-block-stream construct-delegate ; pane-block-stream new-nested-pane-stream ;
! Tables ! Tables
: apply-table-gap-style ( style grid -- style grid ) : apply-table-gap-style ( style grid -- style grid )
@ -273,12 +279,12 @@ M: pane-stream make-block-stream
apply-table-border-style apply-table-border-style
nip ; nip ;
TUPLE: pane-cell-stream ; TUPLE: pane-cell-stream < nested-pane-stream ;
M: pane-cell-stream dispose ?nl ; M: pane-cell-stream dispose ?nl ;
M: pane-stream make-cell-stream M: pane-stream make-cell-stream
<nested-pane-stream> pane-cell-stream construct-delegate ; pane-cell-stream new-nested-pane-stream ;
M: pane-stream stream-write-table M: pane-stream stream-write-table
>r >r
@ -298,7 +304,7 @@ M: paragraph dispose drop ;
M: pack stream-write gadget-write ; M: pack stream-write gadget-write ;
: gadget-bl ( style stream -- ) : gadget-bl ( style stream -- )
>r " " <styled-label> <word-break-gadget> r> add-gadget ; >r " " <word-break-gadget> style-label r> add-gadget ;
M: paragraph stream-write M: paragraph stream-write
swap " " split swap " " split

10
extra/ui/gadgets/paragraphs/paragraphs.factor
View File

@ -5,18 +5,18 @@ namespaces sequences math.order ;
IN: ui.gadgets.paragraphs IN: ui.gadgets.paragraphs
! A word break gadget ! A word break gadget
TUPLE: word-break-gadget ; TUPLE: word-break-gadget < label ;
: <word-break-gadget> ( gadget -- gadget ) : <word-break-gadget> ( text -- gadget )
{ set-delegate } word-break-gadget construct ; word-break-gadget new-label ;
M: word-break-gadget draw-gadget* drop ; M: word-break-gadget draw-gadget* drop ;
! A gadget that arranges its children in a word-wrap style. ! A gadget that arranges its children in a word-wrap style.
TUPLE: paragraph margin ; TUPLE: paragraph < gadget margin ;
: <paragraph> ( margin -- gadget ) : <paragraph> ( margin -- gadget )
paragraph construct-gadget paragraph new-gadget
{ 1 0 } over set-gadget-orientation { 1 0 } over set-gadget-orientation
[ set-paragraph-margin ] keep ; [ set-paragraph-margin ] keep ;

4
extra/ui/gadgets/presentations/presentations-docs.factor
View File

@ -1,6 +1,6 @@
USING: help.markup help.syntax ui.gadgets.buttons USING: help.markup help.syntax ui.gadgets.buttons
ui.gadgets.menus models ui.operations summary kernel ui.gadgets.menus models ui.operations summary kernel
ui.gadgets.worlds ui.gadgets ; ui.gadgets.worlds ui.gadgets ui.gadgets.status-bar ;
IN: ui.gadgets.presentations IN: ui.gadgets.presentations
HELP: presentation HELP: presentation
@ -37,6 +37,8 @@ HELP: <presentation>
{ <commands-menu> <toolbar> operations-menu show-menu } related-words { <commands-menu> <toolbar> operations-menu show-menu } related-words
{ <status-bar> show-mouse-help show-status show-summary hide-status } related-words
HELP: show-mouse-help HELP: show-mouse-help
{ $values { "presentation" presentation } } { $values { "presentation" presentation } }
{ $description "Displays a " { $link summary } " of the " { $link presentation-object } "in the status bar of the " { $link world } " containing this presentation. This word is executed when the mouse enters the presentation." } ; { $description "Displays a " { $link summary } " of the " { $link presentation-object } "in the status bar of the " { $link world } " containing this presentation. This word is executed when the mouse enters the presentation." } ;

26
extra/ui/gadgets/presentations/presentations.factor
View File

@ -1,13 +1,14 @@
! Copyright (C) 2005, 2007 Slava Pestov. ! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays definitions ui.gadgets ui.gadgets.borders USING: arrays accessors definitions hashtables io kernel
ui.gadgets.buttons ui.gadgets.labels ui.gadgets.menus prettyprint sequences strings io.styles words help math models
ui.gadgets.worlds hashtables io kernel prettyprint sequences namespaces quotations
strings io.styles words help math models namespaces quotations ui.gadgets ui.gadgets.borders ui.gadgets.buttons
ui.commands ui.operations ui.gestures ; ui.gadgets.labels ui.gadgets.menus ui.gadgets.worlds
ui.gadgets.status-bar ui.commands ui.operations ui.gestures ;
IN: ui.gadgets.presentations IN: ui.gadgets.presentations
TUPLE: presentation object hook ; TUPLE: presentation < button object hook ;
: invoke-presentation ( presentation command -- ) : invoke-presentation ( presentation command -- )
over dup presentation-hook call over dup presentation-hook call
@ -25,15 +26,14 @@ TUPLE: presentation object hook ;
dup presentation-object over show-summary button-update ; dup presentation-object over show-summary button-update ;
: <presentation> ( label object -- button ) : <presentation> ( label object -- button )
presentation new swap [ invoke-primary ] presentation new-button
[ drop ] over set-presentation-hook swap >>object
[ set-presentation-object ] keep [ drop ] >>hook
swap [ invoke-primary ] <roll-button> roll-button-theme ;
over set-gadget-delegate ;
M: presentation ungraft* M: presentation ungraft*
dup hand-gadget get-global child? [ dup hide-status ] when dup hand-gadget get-global child? [ dup hide-status ] when
delegate ungraft* ; call-next-method ;
: <operations-menu> ( presentation -- menu ) : <operations-menu> ( presentation -- menu )
dup dup presentation-hook curry dup dup presentation-hook curry

27
extra/ui/gadgets/scrollers/scrollers.factor
View File

@ -7,7 +7,7 @@ models models.range models.compose
combinators math.vectors classes.tuple ; combinators math.vectors classes.tuple ;
IN: ui.gadgets.scrollers IN: ui.gadgets.scrollers
TUPLE: scroller viewport x y follows ; TUPLE: scroller < frame viewport x y follows ;
: find-scroller ( gadget -- scroller/f ) : find-scroller ( gadget -- scroller/f )
[ [ scroller? ] is? ] find-parent ; [ [ scroller? ] is? ] find-parent ;
@ -40,14 +40,21 @@ scroller H{
: y-model ( -- model ) g gadget-model model-dependencies second ; : y-model ( -- model ) g gadget-model model-dependencies second ;
: <scroller> ( gadget -- scroller ) : new-scroller ( gadget class -- scroller )
<scroller-model> <frame> scroller construct-control [ new-frame
t >>root?
<scroller-model> >>model
faint-boundary
[
[ [
x-model <x-slider> g-> set-scroller-x @bottom frame, x-model <x-slider> g-> set-scroller-x @bottom frame,
y-model <y-slider> g-> set-scroller-y @right frame, y-model <y-slider> g-> set-scroller-y @right frame,
viewport, viewport,
] with-gadget ] with-gadget
] keep t >>root? faint-boundary ; ] keep ;
: <scroller> ( gadget -- scroller )
scroller new-scroller ;
: scroll ( value scroller -- ) : scroll ( value scroller -- )
[ [
@ -123,7 +130,7 @@ scroller H{
} cond ; } cond ;
M: scroller layout* M: scroller layout*
dup delegate layout* dup call-next-method
dup scroller-follows dup scroller-follows
[ update-scroller ] 2keep [ update-scroller ] 2keep
swap set-scroller-follows ; swap set-scroller-follows ;
@ -134,12 +141,10 @@ M: scroller focusable-child*
M: scroller model-changed M: scroller model-changed
nip f swap set-scroller-follows ; nip f swap set-scroller-follows ;
TUPLE: limited-scroller dim ; TUPLE: limited-scroller < scroller fixed-dim ;
: <limited-scroller> ( gadget -- scroller ) : <limited-scroller> ( gadget dim -- scroller )
<scroller> >r limited-scroller new-scroller r> >>fixed-dim ;
limited-scroller new
[ set-gadget-delegate ] keep ;
M: limited-scroller pref-dim* M: limited-scroller pref-dim*
dim>> ; fixed-dim>> ;

23
extra/ui/gadgets/sliders/sliders.factor
View File

@ -7,12 +7,12 @@ vectors models models.range math.vectors math.functions
quotations colors ; quotations colors ;
IN: ui.gadgets.sliders IN: ui.gadgets.sliders
TUPLE: elevator direction ; TUPLE: elevator < gadget direction ;
: find-elevator ( gadget -- elevator/f ) : find-elevator ( gadget -- elevator/f )
[ elevator? ] find-parent ; [ elevator? ] find-parent ;
TUPLE: slider elevator thumb saved line ; TUPLE: slider < frame elevator thumb saved line ;
: find-slider ( gadget -- slider/f ) : find-slider ( gadget -- slider/f )
[ slider? ] find-parent ; [ slider? ] find-parent ;
@ -50,7 +50,7 @@ TUPLE: slider elevator thumb saved line ;
M: slider model-changed nip slider-elevator relayout-1 ; M: slider model-changed nip slider-elevator relayout-1 ;
TUPLE: thumb ; TUPLE: thumb < gadget ;
: begin-drag ( thumb -- ) : begin-drag ( thumb -- )
find-slider dup slider-value swap set-slider-saved ; find-slider dup slider-value swap set-slider-saved ;
@ -71,9 +71,9 @@ thumb H{
faint-boundary ; inline faint-boundary ; inline
: <thumb> ( vector -- thumb ) : <thumb> ( vector -- thumb )
thumb construct-gadget thumb new-gadget
swap >>orientation swap >>orientation
t >>root? t >>root?
thumb-theme ; thumb-theme ;
: slide-by ( amount slider -- ) : slide-by ( amount slider -- )
@ -104,7 +104,7 @@ elevator H{
lowered-gradient swap set-gadget-interior ; lowered-gradient swap set-gadget-interior ;
: <elevator> ( vector -- elevator ) : <elevator> ( vector -- elevator )
elevator construct-gadget elevator new-gadget
[ set-gadget-orientation ] keep [ set-gadget-orientation ] keep
dup elevator-theme ; dup elevator-theme ;
@ -170,9 +170,10 @@ M: elevator layout*
] with-gadget ; ] with-gadget ;
: <slider> ( range orientation -- slider ) : <slider> ( range orientation -- slider )
swap <frame> slider construct-control slider new-frame
[ set-gadget-orientation ] keep swap >>orientation
32 over set-slider-line ; swap >>model
32 >>line ;
: <x-slider> ( range -- slider ) : <x-slider> ( range -- slider )
{ 1 0 } <slider> dup build-x-slider ; { 1 0 } <slider> dup build-x-slider ;
@ -181,6 +182,6 @@ M: elevator layout*
{ 0 1 } <slider> dup build-y-slider ; { 0 1 } <slider> dup build-y-slider ;
M: slider pref-dim* M: slider pref-dim*
dup delegate pref-dim* dup call-next-method
swap gadget-orientation [ 40 v*n ] keep swap gadget-orientation [ 40 v*n ] keep
set-axis ; set-axis ;

2
extra/ui/gadgets/slots/slots-tests.factor
View File

@ -1,4 +1,6 @@
IN: ui.gadgets.slots.tests IN: ui.gadgets.slots.tests
USING: assocs ui.gadgets.slots tools.test refs ; USING: assocs ui.gadgets.slots tools.test refs ;
\ <editable-slot> must-infer
[ t ] [ { 1 2 3 } 2 <value-ref> <slot-editor> slot-editor? ] unit-test [ t ] [ { 1 2 3 } 2 <value-ref> <slot-editor> slot-editor? ] unit-test

60
extra/ui/gadgets/slots/slots.factor
View File

@ -1,10 +1,10 @@
! Copyright (C) 2007 Slava Pestov. ! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: namespaces ui.gadgets ui.gestures ui.commands kernel USING: accessors namespaces kernel parser prettyprint
ui.gadgets.scrollers parser prettyprint ui.gadgets.buttons sequences arrays io math definitions math.vectors assocs refs
sequences arrays ui.gadgets.borders ui.gadgets.tracks ui.gadgets ui.gestures ui.commands ui.gadgets.scrollers
ui.gadgets.editors io math ui.gadgets.buttons ui.gadgets.borders ui.gadgets.tracks
definitions math.vectors assocs refs ; ui.gadgets.editors ;
IN: ui.gadgets.slots IN: ui.gadgets.slots
TUPLE: update-object ; TUPLE: update-object ;
@ -13,7 +13,7 @@ TUPLE: update-slot ;
TUPLE: edit-slot ; TUPLE: edit-slot ;
TUPLE: slot-editor ref text ; TUPLE: slot-editor < track ref text ;
: revert ( slot-editor -- ) : revert ( slot-editor -- )
dup slot-editor-ref get-ref unparse-use dup slot-editor-ref get-ref unparse-use
@ -69,16 +69,20 @@ M: value-ref finish-editing
} define-command } define-command
: <slot-editor> ( ref -- gadget ) : <slot-editor> ( ref -- gadget )
slot-editor new { 0 1 } slot-editor new-track
[ set-slot-editor-ref ] keep swap >>ref
[ [
toolbar, [
<source-editor> g-> set-slot-editor-text toolbar,
<scroller> 1 track, <source-editor> g-> set-slot-editor-text
] { 0 1 } build-track <scroller> 1 track,
] with-gadget
] keep
dup revert ; dup revert ;
M: slot-editor pref-dim* delegate pref-dim* { 600 200 } vmin ; M: slot-editor pref-dim* call-next-method { 600 200 } vmin ;
M: slot-editor focusable-child* text>> ;
slot-editor "toolbar" f { slot-editor "toolbar" f {
{ T{ key-down f { C+ } "RET" } commit } { T{ key-down f { C+ } "RET" } commit }
@ -88,7 +92,7 @@ slot-editor "toolbar" f {
{ T{ key-down f f "ESC" } close } { T{ key-down f f "ESC" } close }
} define-command-map } define-command-map
TUPLE: editable-slot printer ref ; TUPLE: editable-slot < track printer ref ;
: <edit-button> ( -- gadget ) : <edit-button> ( -- gadget )
"..." "..."
@ -100,17 +104,16 @@ TUPLE: editable-slot printer ref ;
[ 1 track, <edit-button> f track, ] with-gadget ; [ 1 track, <edit-button> f track, ] with-gadget ;
: update-slot ( editable-slot -- ) : update-slot ( editable-slot -- )
[ [ [ ref>> get-ref ] [ printer>> ] bi call ] keep
dup editable-slot-ref get-ref display-slot ;
swap editable-slot-printer call
] keep
[ display-slot ] keep
scroll>gadget ;
: edit-slot ( editable-slot -- ) : edit-slot ( editable-slot -- )
dup clear-track dup [ [ clear-track ]
dup editable-slot-ref <slot-editor> 1 track, [
] with-gadget scroll>gadget ; dup ref>> <slot-editor>
[ swap 1 track-add ]
[ [ scroll>gadget ] [ request-focus ] bi* ] 2bi
] bi ;
\ editable-slot H{ \ editable-slot H{
{ T{ update-slot } [ update-slot ] } { T{ update-slot } [ update-slot ] }
@ -118,8 +121,7 @@ TUPLE: editable-slot printer ref ;
} set-gestures } set-gestures
: <editable-slot> ( gadget ref -- editable-slot ) : <editable-slot> ( gadget ref -- editable-slot )
editable-slot new { 1 0 } editable-slot new-track
{ 1 0 } <track> over set-gadget-delegate swap >>ref
[ drop <gadget> ] over set-editable-slot-printer [ drop <gadget> ] >>printer
[ set-editable-slot-ref ] keep [ display-slot ] keep ;
[ display-slot ] keep ;

6
extra/ui/gadgets/status-bar/status-bar-docs.factor
View File

@ -1,10 +1,8 @@
USING: ui.gadgets.presentations help.markup help.syntax models USING: help.markup help.syntax models
ui.gadgets ui.gadgets.worlds ; ui.gadgets ui.gadgets.worlds ;
IN: ui.gadgets.status-bar IN: ui.gadgets.status-bar
HELP: <status-bar> HELP: <status-bar>
{ $values { "model" model } { "gadget" "a new " { $link gadget } } } { $values { "model" model } { "gadget" "a new " { $link gadget } } }
{ $description "Creates a new " { $link gadget } " displaying the model value, which must be a string or " { $link f } "." } { $description "Creates a new " { $link gadget } " displaying the model value, which must be a string or " { $link f } "." }
{ $notes "If the " { $snippet "model" } " is " { $link world-status } ", this gadget will display " { $link presentation } " mouse over help." } ; { $notes "If the " { $snippet "model" } " is " { $link world-status } ", this gadget will display mouse over help for " { $link "ui.gadgets.presentations" } "." } ;
{ <status-bar> show-mouse-help show-status show-summary hide-status } related-words

12
extra/ui/gadgets/status-bar/status-bar.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors models models.delay models.filter USING: accessors models models.delay models.filter
sequences ui.gadgets.labels ui.gadgets.theme ui.gadgets.tracks sequences ui.gadgets.labels ui.gadgets.theme ui.gadgets.tracks
ui.gadgets.worlds ui.gadgets ui kernel calendar ; ui.gadgets.worlds ui.gadgets ui kernel calendar summary ;
IN: ui.gadgets.status-bar IN: ui.gadgets.status-bar
: <status-bar> ( model -- gadget ) : <status-bar> ( model -- gadget )
@ -11,7 +11,9 @@ IN: ui.gadgets.status-bar
t >>root? ; t >>root? ;
: open-status-window ( gadget title -- ) : open-status-window ( gadget title -- )
>r [ f <model> [ <world> ] keep
1 track, <status-bar> over f track-add
f <model> dup <status-bar> f track, open-world-window ;
] { 0 1 } make-track r> rot <world> open-world-window ;
: show-summary ( object gadget -- )
>r [ summary ] [ "" ] if* r> show-status ;

12
extra/ui/gadgets/tabs/tabs.factor
View File

@ -24,13 +24,16 @@ DEFER: (del-page)
[ [ length ] keep ] 2dip [ [ length ] keep ] 2dip
'[ , _ _ , add-toggle ] 2each ; '[ , _ _ , add-toggle ] 2each ;
: refresh-book ( tabbed -- )
model>> [ ] change-model ;
: (del-page) ( n name tabbed -- ) : (del-page) ( n name tabbed -- )
{ [ [ remove ] change-names redo-toggler ] { [ [ remove ] change-names redo-toggler ]
[ [ names>> length ] [ model>> ] bi [ dupd [ names>> length ] [ model>> ] bi
[ [ = ] keep swap [ 1- ] when [ [ = ] keep swap [ 1- ] when
[ > ] keep swap [ 1- ] when dup ] change-model ] [ < ] keep swap [ 1- ] when ] change-model ]
[ content>> nth-gadget unparent ] [ content>> nth-gadget unparent ]
[ model>> [ ] change-model ] ! refresh [ refresh-book ]
} cleave ; } cleave ;
: add-page ( page name tabbed -- ) : add-page ( page name tabbed -- )
@ -38,7 +41,8 @@ DEFER: (del-page)
[ [ model>> swap ] [ [ model>> swap ]
[ names>> length 1 - swap ] [ names>> length 1 - swap ]
[ toggler>> ] tri add-toggle ] [ toggler>> ] tri add-toggle ]
[ content>> add-gadget ] bi ; [ content>> add-gadget ]
[ refresh-book ] tri ;
: del-page ( name tabbed -- ) : del-page ( name tabbed -- )
[ names>> index ] 2keep (del-page) ; [ names>> index ] 2keep (del-page) ;

19
extra/ui/gadgets/tracks/tracks-docs.factor
View File

@ -2,6 +2,17 @@ USING: ui.gadgets.packs help.markup help.syntax ui.gadgets
arrays kernel quotations classes.tuple ; arrays kernel quotations classes.tuple ;
IN: ui.gadgets.tracks IN: ui.gadgets.tracks
ARTICLE: "ui-track-layout" "Track layouts"
"Track gadgets are like " { $link "ui-pack-layout" } " except each child is resized to a fixed multiple of the track's dimension."
{ $subsection track }
"Creating empty tracks:"
{ $subsection <track> }
"Adding children:"
{ $subsection track-add }
"Creating new tracks using a combinator:"
{ $subsection make-track }
{ $subsection track, } ;
HELP: track HELP: track
{ $class-description "A track is like a " { $link pack } " except each child is resized to a fixed multiple of the track's dimension in the direction of " { $link gadget-orientation } ". Tracks are created by calling " { $link <track> } "." } ; { $class-description "A track is like a " { $link pack } " except each child is resized to a fixed multiple of the track's dimension in the direction of " { $link gadget-orientation } ". Tracks are created by calling " { $link <track> } "." } ;
@ -9,7 +20,7 @@ HELP: <track>
{ $values { "orientation" "an orientation specifier" } { "track" "a new " { $link track } } } { $values { "orientation" "an orientation specifier" } { "track" "a new " { $link track } } }
{ $description "Creates a new track which lays out children along the given axis. Children are laid out vertically if the orientation is " { $snippet "{ 0 1 }" } " and horizontally if the orientation is " { $snippet "{ 1 0 }" } "." } ; { $description "Creates a new track which lays out children along the given axis. Children are laid out vertically if the orientation is " { $snippet "{ 0 1 }" } " and horizontally if the orientation is " { $snippet "{ 1 0 }" } "." } ;
{ <track> make-track build-track } related-words { <track> make-track } related-words
HELP: track-add HELP: track-add
{ $values { "gadget" gadget } { "track" track } { "constraint" "a number between 0 and 1, or " { $link f } } } { $values { "gadget" gadget } { "track" track } { "constraint" "a number between 0 and 1, or " { $link f } } }
@ -17,12 +28,10 @@ HELP: track-add
HELP: track, HELP: track,
{ $values { "gadget" gadget } { "constraint" "a number between 0 and 1, or " { $link f } } } { $values { "gadget" gadget } { "constraint" "a number between 0 and 1, or " { $link f } } }
{ $description "Adds a new child to a track. If the constraint is " { $link f } ", the child always occupies its preferred size. Otherwise, the constrant is a fraction of the total size which is allocated for the child. This word can only be called inside the quotation passed to " { $link make-track } " or " { $link build-track } "." } ; { $description "Adds a new child to a track. If the constraint is " { $link f } ", the child always occupies its preferred size. Otherwise, the constrant is a fraction of the total size which is allocated for the child. This word can only be called inside the quotation passed to " { $link make-track } "." } ;
HELP: make-track HELP: make-track
{ $values { "quot" quotation } { "orientation" "an orientation specifier" } { "track" track } } { $values { "quot" quotation } { "orientation" "an orientation specifier" } { "track" track } }
{ $description "Creates a new track. The quotation can add children by calling the " { $link track, } " word." } ; { $description "Creates a new track. The quotation can add children by calling the " { $link track, } " word." } ;
HELP: build-track ABOUT: "ui-track-layout"
{ $values { "tuple" tuple } { "quot" quotation } { "orientation" "an orientation specifier" } }
{ $description "Creates a new track and sets " { $snippet "tuple" } "'s delegate to the new track. The quotation can add children by calling the " { $link track, } " word, and access the track by calling " { $link g } " or " { $link g-> } "." } ;

21
extra/ui/gadgets/tracks/tracks.factor
View File

@ -1,19 +1,23 @@
! Copyright (C) 2006, 2007 Slava Pestov. ! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: ui.gadgets ui.gadgets.packs io kernel math namespaces USING: accessors io kernel math namespaces
sequences words math.vectors ; sequences words math.vectors ui.gadgets ui.gadgets.packs ;
IN: ui.gadgets.tracks IN: ui.gadgets.tracks
TUPLE: track sizes ; TUPLE: track < pack sizes ;
: normalized-sizes ( track -- seq ) : normalized-sizes ( track -- seq )
track-sizes track-sizes
[ sift sum ] keep [ dup [ over / ] when ] map nip ; [ sift sum ] keep [ dup [ over / ] when ] map nip ;
: new-track ( orientation class -- track )
new-gadget
swap >>orientation
V{ } clone >>sizes
1 >>fill ; inline
: <track> ( orientation -- track ) : <track> ( orientation -- track )
<pack> V{ } clone track new-track ;
{ set-delegate set-track-sizes } track construct
1 over set-pack-fill ;
: alloted-dim ( track -- dim ) : alloted-dim ( track -- dim )
dup gadget-children swap track-sizes { 0 0 } dup gadget-children swap track-sizes { 0 0 }
@ -51,9 +55,6 @@ M: track pref-dim*
: make-track ( quot orientation -- track ) : make-track ( quot orientation -- track )
<track> make-gadget ; inline <track> make-gadget ; inline
: build-track ( tuple quot orientation -- tuple )
<track> build-gadget ; inline
: track-remove ( gadget track -- ) : track-remove ( gadget track -- )
over [ over [
[ gadget-children index ] 2keep [ gadget-children index ] 2keep

13
extra/ui/gadgets/viewports/viewports.factor
View File

@ -1,12 +1,12 @@
! Copyright (C) 2005, 2007 Slava Pestov. ! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
IN: ui.gadgets.viewports IN: ui.gadgets.viewports
USING: arrays ui.gadgets ui.gadgets.borders USING: accessors arrays ui.gadgets ui.gadgets.borders
kernel math namespaces sequences models math.vectors ; kernel math namespaces sequences models math.vectors ;
: viewport-gap { 3 3 } ; inline : viewport-gap { 3 3 } ; inline
TUPLE: viewport ; TUPLE: viewport < gadget ;
: find-viewport ( gadget -- viewport ) : find-viewport ( gadget -- viewport )
[ viewport? ] find-parent ; [ viewport? ] find-parent ;
@ -15,9 +15,10 @@ TUPLE: viewport ;
gadget-child pref-dim viewport-gap 2 v*n v+ ; gadget-child pref-dim viewport-gap 2 v*n v+ ;
: <viewport> ( content model -- viewport ) : <viewport> ( content model -- viewport )
<gadget> viewport construct-control viewport new-gadget
t over set-gadget-clipped? swap >>model
[ add-gadget ] keep ; t >>clipped?
[ add-gadget ] keep ;
M: viewport layout* M: viewport layout*
dup rect-dim viewport-gap 2 v*n v- dup rect-dim viewport-gap 2 v*n v-

18
extra/ui/gadgets/worlds/worlds-docs.factor
View File

@ -29,15 +29,15 @@ HELP: focus-path
HELP: world HELP: world
{ $class-description "A gadget which appears at the top of the gadget hieararchy, and in turn may be displayed in a native window. Worlds delegate to " { $link gadget } " instances and have the following slots:" { $class-description "A gadget which appears at the top of the gadget hieararchy, and in turn may be displayed in a native window. Worlds delegate to " { $link gadget } " instances and have the following slots:"
{ $list { $list
{ { $link world-active? } " - if set to " { $link f } ", the world will not be drawn. This slot is set to " { $link f } " if an error is thrown while drawing the world; this prevents multiple debugger windows from being shown." } { { $snippet "active?" } " - if set to " { $link f } ", the world will not be drawn. This slot is set to " { $link f } " if an error is thrown while drawing the world; this prevents multiple debugger windows from being shown." }
{ { $link world-glass } " - a glass pane in front of the primary gadget, used to implement behaviors such as popup menus which are hidden when the mouse is clicked outside the menu." } { { $snippet "glass" } " - a glass pane in front of the primary gadget, used to implement behaviors such as popup menus which are hidden when the mouse is clicked outside the menu." }
{ { $link world-title } " - a string to be displayed in the title bar of the native window containing the world." } { { $snippet "title" } " - a string to be displayed in the title bar of the native window containing the world." }
{ { $link world-status } " - a " { $link model } " holding a string to be displayed in the world's status bar." } { { $snippet "status" } " - a " { $link model } " holding a string to be displayed in the world's status bar." }
{ { $link world-focus } " - the current owner of the keyboard focus in the world." } { { $snippet "focus" } " - the current owner of the keyboard focus in the world." }
{ { $link world-focused? } " - a boolean indicating if the native window containing the world has keyboard focus." } { { $snippet "focused?" } " - a boolean indicating if the native window containing the world has keyboard focus." }
{ { $link world-fonts } " - a hashtable mapping font instances to vectors of " { $link sprite } " instances." } { { $snippet "fonts" } " - a hashtable mapping font instances to vectors of " { $link sprite } " instances." }
{ { $link world-handle } " - a backend-specific native handle representing the native window containing the world, or " { $link f } " if the world is not grafted." } { { $snippet "handle" } " - a backend-specific native handle representing the native window containing the world, or " { $link f } " if the world is not grafted." }
{ { $link world-loc } " - the on-screen location of the native window containing the world. The co-ordinate system here is backend-specific." } { { $snippet "window-loc" } " - the on-screen location of the native window containing the world. The co-ordinate system here is backend-specific." }
} }
} ; } ;

10
extra/ui/gadgets/worlds/worlds-tests.factor
View File

@ -6,7 +6,7 @@ namespaces models kernel ;
<gadget> "g1" set <gadget> "g1" set
: <test-world> ( gadget -- world ) : <test-world> ( gadget -- world )
[ gadget, ] make-pile "Hi" f <world> ; "Hi" f <world> ;
[ ] [ [ ] [
"g1" get <test-world> "w" set "g1" get <test-world> "w" set
@ -46,15 +46,15 @@ namespaces models kernel ;
[ t ] [ <gadget> dup <test-world> focusable-child eq? ] unit-test [ t ] [ <gadget> dup <test-world> focusable-child eq? ] unit-test
TUPLE: focusing ; TUPLE: focusing < gadget ;
: <focusing> : <focusing>
focusing construct-gadget ; focusing new-gadget ;
TUPLE: focus-test ; TUPLE: focus-test < gadget ;
: <focus-test> : <focus-test>
focus-test construct-gadget focus-test new-gadget
<focusing> over add-gadget ; <focusing> over add-gadget ;
M: focus-test focusable-child* gadget-child ; M: focus-test focusable-child* gadget-child ;

38
extra/ui/gadgets/worlds/worlds.factor
View File

@ -1,17 +1,17 @@
! Copyright (C) 2005, 2008 Slava Pestov. ! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs continuations kernel math models USING: accessors arrays assocs continuations kernel math models
namespaces opengl sequences io combinators math.vectors namespaces opengl sequences io combinators math.vectors
ui.gadgets ui.gestures ui.render ui.backend summary ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks
debugger ; debugger ;
IN: ui.gadgets.worlds IN: ui.gadgets.worlds
TUPLE: world < identity-tuple TUPLE: world < track
active? focused? active? focused?
glass glass
title status title status
fonts handle fonts handle
loc ; window-loc ;
: find-world ( gadget -- world ) [ world? ] find-parent ; : find-world ( gadget -- world ) [ world? ] find-parent ;
@ -20,9 +20,6 @@ M: f world-status ;
: show-status ( string/f gadget -- ) : show-status ( string/f gadget -- )
find-world world-status [ set-model ] [ drop ] if* ; find-world world-status [ set-model ] [ drop ] if* ;
: show-summary ( object gadget -- )
>r [ summary ] [ "" ] if* r> show-status ;
: hide-status ( gadget -- ) f swap show-status ; : hide-status ( gadget -- ) f swap show-status ;
: (request-focus) ( child world ? -- ) : (request-focus) ( child world ? -- )
@ -36,21 +33,18 @@ M: world request-focus-on ( child gadget -- )
[ 2drop ] [ dup world-focused? (request-focus) ] if ; [ 2drop ] [ dup world-focused? (request-focus) ] if ;
: <world> ( gadget title status -- world ) : <world> ( gadget title status -- world )
t H{ } clone { 0 0 } { { 0 1 } world new-track
set-gadget-delegate t >>root?
set-world-title t >>active?
set-world-status H{ } clone >>fonts
set-world-active? { 0 0 } >>window-loc
set-world-fonts swap >>status
set-world-loc swap >>title
} world construct [ 1 track-add ] keep
t over set-gadget-root?
dup request-focus ; dup request-focus ;
M: world hashcode* drop world hashcode* ;
M: world layout* M: world layout*
dup delegate layout* dup call-next-method
dup world-glass [ dup world-glass [
>r dup rect-dim r> set-layout-dim >r dup rect-dim r> set-layout-dim
] when* drop ; ] when* drop ;
@ -71,11 +65,9 @@ M: world children-on nip gadget-children ;
over world-handle over world-handle
rot rect-dim [ 0 > ] all? and and ; rot rect-dim [ 0 > ] all? and and ;
TUPLE: world-error world ; TUPLE: world-error error world ;
: <world-error> ( error world -- error ) C: <world-error> world-error
{ set-delegate set-world-error-world }
world-error construct ;
SYMBOL: ui-error-hook SYMBOL: ui-error-hook

22
extra/ui/gadgets/wrappers/wrappers.factor Normal file
View File

@ -0,0 +1,22 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors ui.gadgets kernel ;
IN: ui.gadgets.wrappers
TUPLE: wrapper < gadget ;
: new-wrapper ( child class -- wrapper )
new-gadget
[ add-gadget ] keep ; inline
: <wrapper> ( child -- border )
wrapper new-wrapper ;
M: wrapper pref-dim*
gadget-child pref-dim ;
M: wrapper layout*
[ dim>> ] [ gadget-child ] bi set-layout-dim ;
M: wrapper focusable-child*
gadget-child ;

2
extra/ui/gestures/gestures.factor
View File

@ -11,7 +11,7 @@ IN: ui.gestures
GENERIC: handle-gesture* ( gadget gesture delegate -- ? ) GENERIC: handle-gesture* ( gadget gesture delegate -- ? )
: default-gesture-handler ( gadget gesture delegate -- ? ) : default-gesture-handler ( gadget gesture delegate -- ? )
class "gestures" word-prop at dup class superclasses [ "gestures" word-prop ] map assoc-stack dup
[ call f ] [ 2drop t ] if ; [ call f ] [ 2drop t ] if ;
M: object handle-gesture* default-gesture-handler ; M: object handle-gesture* default-gesture-handler ;

19
extra/ui/operations/operations.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2006, 2007 Slava Pestov. ! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays definitions kernel ui.commands ui.gestures USING: accessors arrays definitions kernel ui.commands
sequences strings math words generic namespaces hashtables ui.gestures sequences strings math words generic namespaces
help.markup quotations assocs ; hashtables help.markup quotations assocs ;
IN: ui.operations IN: ui.operations
SYMBOL: +keyboard+ SYMBOL: +keyboard+
@ -12,12 +12,11 @@ SYMBOL: +secondary+
TUPLE: operation predicate command translator hook listener? ; TUPLE: operation predicate command translator hook listener? ;
: <operation> ( predicate command -- operation ) : <operation> ( predicate command -- operation )
[ ] [ ] { operation new
set-operation-predicate [ ] >>hook
set-operation-command [ ] >>translator
set-operation-translator swap >>command
set-operation-hook swap >>predicate ;
} operation construct ;
PREDICATE: listener-operation < operation PREDICATE: listener-operation < operation
dup operation-command listener-command? dup operation-command listener-command?

6
extra/ui/render/render-docs.factor
View File

@ -17,11 +17,9 @@ HELP: gadget
{ { $link gadget-boundary } " - an object whose class implements the " { $link draw-boundary } " generic word." } { { $link gadget-boundary } " - an object whose class implements the " { $link draw-boundary } " generic word." }
{ { $link gadget-model } " - a " { $link model } " or " { $link f } "; see " { $link "ui-control-impl" } } { { $link gadget-model } " - a " { $link model } " or " { $link f } "; see " { $link "ui-control-impl" } }
} }
"Gadgets delegate to " { $link rect } " instances holding their location and dimensions." } "Gadgets subclass the " { $link rect } " class, and thus all instances have " { $snippet "loc" } " and " { $snippet "dim" } " instances holding their location and dimensions." }
{ $notes { $notes
"Other classes may delegate to " { $link gadget } " in order to re-implement generic words such as " { $link draw-gadget* } " and " { $link user-input* } ", or to define gestures with " { $link set-gestures } "." } "Other classes may delegate to " { $link gadget } " in order to re-implement generic words such as " { $link draw-gadget* } " and " { $link user-input* } ", or to define gestures with " { $link set-gestures } "." } ;
{ $warning
"When setting a tuple's delegate to be a gadget, " { $link set-gadget-delegate } " should be used instead of " { $link set-delegate } "." } ;
HELP: clip HELP: clip
{ $var-description "The current clipping rectangle." } ; { $var-description "The current clipping rectangle." } ;

23
extra/ui/tools/browser/browser.factor
View File

@ -7,7 +7,7 @@ ui.gadgets.buttons compiler.units assocs words vocabs
accessors ; accessors ;
IN: ui.tools.browser IN: ui.tools.browser
TUPLE: browser-gadget pane history ; TUPLE: browser-gadget < track pane history ;
: show-help ( link help -- ) : show-help ( link help -- )
dup history>> add-history dup history>> add-history
@ -20,12 +20,15 @@ TUPLE: browser-gadget pane history ;
"handbook" >link <history> >>history drop ; "handbook" >link <history> >>history drop ;
: <browser-gadget> ( -- gadget ) : <browser-gadget> ( -- gadget )
browser-gadget new { 0 1 } browser-gadget new-track
dup init-history [ dup init-history
toolbar, [
g <help-pane> g-> set-browser-gadget-pane [
<scroller> 1 track, toolbar,
] { 0 1 } build-track ; g <help-pane> g-> set-browser-gadget-pane
<scroller> 1 track,
] with-gadget
] keep ;
M: browser-gadget call-tool* show-help ; M: browser-gadget call-tool* show-help ;
@ -33,12 +36,10 @@ M: browser-gadget tool-scroller
pane>> find-scroller ; pane>> find-scroller ;
M: browser-gadget graft* M: browser-gadget graft*
dup add-definition-observer [ add-definition-observer ] [ call-next-method ] bi ;
delegate graft* ;
M: browser-gadget ungraft* M: browser-gadget ungraft*
dup delegate ungraft* [ call-next-method ] [ remove-definition-observer ] bi ;
remove-definition-observer ;
: showing-definition? ( defspec assoc -- ? ) : showing-definition? ( defspec assoc -- ? )
[ key? ] 2keep [ key? ] 2keep

22
extra/ui/tools/debugger/debugger.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2006, 2007 Slava Pestov. ! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays ui ui.commands ui.gestures ui.gadgets USING: accessors arrays ui ui.commands ui.gestures ui.gadgets
ui.gadgets.worlds ui.gadgets.packs ui.gadgets.buttons ui.gadgets.worlds ui.gadgets.packs ui.gadgets.buttons
ui.gadgets.labels ui.gadgets.panes ui.gadgets.presentations ui.gadgets.labels ui.gadgets.panes ui.gadgets.presentations
ui.gadgets.viewports ui.gadgets.lists ui.gadgets.tracks ui.gadgets.viewports ui.gadgets.lists ui.gadgets.tracks
@ -12,7 +12,7 @@ IN: ui.tools.debugger
: <restart-list> ( restarts restart-hook -- gadget ) : <restart-list> ( restarts restart-hook -- gadget )
[ restart-name ] rot <model> <list> ; [ restart-name ] rot <model> <list> ;
TUPLE: debugger restarts ; TUPLE: debugger < track restarts ;
: <debugger-display> ( restart-list error -- gadget ) : <debugger-display> ( restart-list error -- gadget )
[ [
@ -21,12 +21,14 @@ TUPLE: debugger restarts ;
] make-filled-pile ; ] make-filled-pile ;
: <debugger> ( error restarts restart-hook -- gadget ) : <debugger> ( error restarts restart-hook -- gadget )
debugger new { 0 1 } debugger new-track
[ [
toolbar, [
<restart-list> g-> set-debugger-restarts toolbar,
swap <debugger-display> <scroller> 1 track, <restart-list> g-> set-debugger-restarts
] { 0 1 } build-track ; swap <debugger-display> <scroller> 1 track,
] with-gadget
] keep ;
M: debugger focusable-child* debugger-restarts ; M: debugger focusable-child* debugger-restarts ;
@ -38,9 +40,9 @@ M: debugger focusable-child* debugger-restarts ;
M: world-error error. M: world-error error.
"An error occurred while drawing the world " write "An error occurred while drawing the world " write
dup world-error-world pprint-short "." print dup world>> pprint-short "." print
"This world has been deactivated to prevent cascading errors." print "This world has been deactivated to prevent cascading errors." print
delegate error. ; error>> error. ;
debugger "gestures" f { debugger "gestures" f {
{ T{ button-down } request-focus } { T{ button-down } request-focus }

17
extra/ui/tools/deploy/deploy.factor
View File

@ -8,7 +8,7 @@ ui.commands assocs ui.gadgets.tracks ui ui.tools.listener
tools.deploy vocabs ui.tools.workspace system accessors ; tools.deploy vocabs ui.tools.workspace system accessors ;
IN: ui.tools.deploy IN: ui.tools.deploy
TUPLE: deploy-gadget vocab settings ; TUPLE: deploy-gadget < pack vocab settings ;
: bundle-name ( -- ) : bundle-name ( -- )
deploy-name get <field> deploy-name get <field>
@ -105,11 +105,16 @@ deploy-gadget "toolbar" f {
g <toolbar> { 10 10 } over set-pack-gap gadget, ; g <toolbar> { 10 10 } over set-pack-gap gadget, ;
: <deploy-gadget> ( vocab -- gadget ) : <deploy-gadget> ( vocab -- gadget )
f deploy-gadget boa [ deploy-gadget new-gadget
dup <deploy-settings> swap >>vocab
g-> set-deploy-gadget-settings gadget, { 0 1 } >>orientation
buttons, [
] { 0 1 } build-pack [
g vocab>> <deploy-settings>
g-> set-deploy-gadget-settings gadget,
buttons,
] with-gadget
] keep
dup deploy-settings-theme dup deploy-settings-theme
dup com-revert ; dup com-revert ;

12
extra/ui/tools/inspector/inspector.factor
View File

@ -6,7 +6,7 @@ ui.gadgets.slots ui.gadgets.tracks ui.gestures
ui.gadgets.buttons namespaces ; ui.gadgets.buttons namespaces ;
IN: ui.tools.inspector IN: ui.tools.inspector
TUPLE: inspector-gadget object pane ; TUPLE: inspector-gadget < track object pane ;
: refresh ( inspector -- ) : refresh ( inspector -- )
dup inspector-gadget-object swap inspector-gadget-pane [ dup inspector-gadget-object swap inspector-gadget-pane [
@ -14,11 +14,13 @@ TUPLE: inspector-gadget object pane ;
] with-pane ; ] with-pane ;
: <inspector-gadget> ( -- gadget ) : <inspector-gadget> ( -- gadget )
inspector-gadget new { 0 1 } inspector-gadget new-track
[ [
toolbar, [
<pane> g-> set-inspector-gadget-pane <scroller> 1 track, toolbar,
] { 0 1 } build-track ; <pane> g-> set-inspector-gadget-pane <scroller> 1 track,
] with-gadget
] keep ;
: inspect-object ( obj inspector -- ) : inspect-object ( obj inspector -- )
[ set-inspector-gadget-object ] keep refresh ; [ set-inspector-gadget-object ] keep refresh ;

16
extra/ui/tools/interactor/interactor.factor
View File

@ -4,7 +4,7 @@ USING: arrays assocs combinators continuations documents
hashtables io io.styles kernel math math.order math.vectors hashtables io io.styles kernel math math.order math.vectors
models models.delay namespaces parser lexer prettyprint models models.delay namespaces parser lexer prettyprint
quotations sequences strings threads listener classes.tuple quotations sequences strings threads listener classes.tuple
ui.commands ui.gadgets ui.gadgets.editors ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.status-bar
ui.gadgets.presentations ui.gadgets.worlds ui.gestures ui.gadgets.presentations ui.gadgets.worlds ui.gestures
definitions calendar concurrency.flags concurrency.mailboxes definitions calendar concurrency.flags concurrency.mailboxes
ui.tools.workspace accessors sets destructors ; ui.tools.workspace accessors sets destructors ;
@ -12,7 +12,8 @@ IN: ui.tools.interactor
! If waiting is t, we're waiting for user input, and invoking ! If waiting is t, we're waiting for user input, and invoking
! evaluate-input resumes the thread. ! evaluate-input resumes the thread.
TUPLE: interactor output history flag mailbox thread waiting help ; TUPLE: interactor < source-editor
output history flag mailbox thread waiting help ;
: register-self ( interactor -- ) : register-self ( interactor -- )
<mailbox> >>mailbox <mailbox> >>mailbox
@ -39,18 +40,17 @@ TUPLE: interactor output history flag mailbox thread waiting help ;
editor-caret 1/3 seconds <delay> ; editor-caret 1/3 seconds <delay> ;
: <interactor> ( output -- gadget ) : <interactor> ( output -- gadget )
<source-editor> interactor new-editor
interactor construct-editor
V{ } clone >>history V{ } clone >>history
<flag> >>flag <flag> >>flag
dup <help-model> >>help dup <help-model> >>help
swap >>output ; swap >>output ;
M: interactor graft* M: interactor graft*
[ delegate graft* ] [ dup help>> add-connection ] bi ; [ call-next-method ] [ dup help>> add-connection ] bi ;
M: interactor ungraft* M: interactor ungraft*
[ dup help>> remove-connection ] [ delegate ungraft ] bi ; [ dup help>> remove-connection ] [ call-next-method ] bi ;
: word-at-loc ( loc interactor -- word ) : word-at-loc ( loc interactor -- word )
over [ over [
@ -64,7 +64,7 @@ M: interactor model-changed
2dup help>> eq? [ 2dup help>> eq? [
swap model-value over word-at-loc swap show-summary swap model-value over word-at-loc swap show-summary
] [ ] [
delegate model-changed call-next-method
] if ; ] if ;
: write-input ( string input -- ) : write-input ( string input -- )
@ -180,7 +180,7 @@ M: interactor stream-read-quot
} cond ; } cond ;
M: interactor pref-dim* M: interactor pref-dim*
[ line-height 4 * 0 swap 2array ] [ delegate pref-dim* ] bi [ line-height 4 * 0 swap 2array ] [ call-next-method ] bi
vmax ; vmax ;
interactor "interactor" f { interactor "interactor" f {

2
extra/ui/tools/listener/listener-tests.factor
View File

@ -5,7 +5,7 @@ ui.gadgets.panes vocabs words tools.test.ui slots.private
threads arrays generic threads accessors listener ; threads arrays generic threads accessors listener ;
IN: ui.tools.listener.tests IN: ui.tools.listener.tests
[ f ] [ "word" source-editor command-map empty? ] unit-test [ f ] [ "word" source-editor command-map commands>> empty? ] unit-test
[ ] [ <listener-gadget> [ ] with-grafted-gadget ] unit-test [ ] [ <listener-gadget> [ ] with-grafted-gadget ] unit-test

30
extra/ui/tools/listener/listener.factor
View File

@ -10,7 +10,7 @@ prettyprint listener debugger threads boxes concurrency.flags
math arrays generic accessors combinators assocs ; math arrays generic accessors combinators assocs ;
IN: ui.tools.listener IN: ui.tools.listener
TUPLE: listener-gadget input output stack ; TUPLE: listener-gadget < track input output stack ;
: listener-output, ( -- ) : listener-output, ( -- )
<scrolling-pane> g-> set-listener-gadget-output <scrolling-pane> g-> set-listener-gadget-output
@ -24,7 +24,7 @@ TUPLE: listener-gadget input output stack ;
: listener-input, ( -- ) : listener-input, ( -- )
g <listener-input> g-> set-listener-gadget-input g <listener-input> g-> set-listener-gadget-input
<limited-scroller> { 0 100 } >>dim { 0 100 } <limited-scroller>
"Input" <labelled-gadget> f track, ; "Input" <labelled-gadget> f track, ;
: welcome. ( -- ) : welcome. ( -- )
@ -118,15 +118,18 @@ M: engine-word word-completion-string
dup "\n" join pick add-interactor-history dup "\n" join pick add-interactor-history
swap select-all ; swap select-all ;
TUPLE: stack-display ; TUPLE: stack-display < track ;
: <stack-display> ( -- gadget ) : <stack-display> ( -- gadget )
stack-display new g workspace-listener
g workspace-listener swap [ { 0 1 } stack-display new-track
dup <toolbar> f track, [
stack>> [ [ stack. ] curry try ] [
t "Data stack" <labelled-pane> 1 track, dup <toolbar> f track,
] { 0 1 } build-track ; stack>> [ [ stack. ] curry try ]
t "Data stack" <labelled-pane> 1 track,
] with-gadget
] keep ;
M: stack-display tool-scroller M: stack-display tool-scroller
find-workspace workspace-listener tool-scroller ; find-workspace workspace-listener tool-scroller ;
@ -169,8 +172,9 @@ M: stack-display tool-scroller
f <model> swap set-listener-gadget-stack ; f <model> swap set-listener-gadget-stack ;
: <listener-gadget> ( -- gadget ) : <listener-gadget> ( -- gadget )
listener-gadget new dup init-listener { 0 1 } listener-gadget new-track
[ listener-output, listener-input, ] { 0 1 } build-track ; dup init-listener
[ [ listener-output, listener-input, ] with-gadget ] keep ;
: listener-help ( -- ) "ui-listener" help-window ; : listener-help ( -- ) "ui-listener" help-window ;
@ -189,7 +193,7 @@ M: listener-gadget handle-gesture* ( gadget gesture delegate -- ? )
[ default-gesture-handler ] [ 3drop f ] if ; [ default-gesture-handler ] [ 3drop f ] if ;
M: listener-gadget graft* M: listener-gadget graft*
[ delegate graft* ] [ restart-listener ] bi ; [ call-next-method ] [ restart-listener ] bi ;
M: listener-gadget ungraft* M: listener-gadget ungraft*
[ com-end ] [ delegate ungraft* ] bi ; [ com-end ] [ call-next-method ] bi ;

14
extra/ui/tools/profiler/profiler.factor
View File

@ -5,15 +5,17 @@ ui.commands ui.gadgets ui.gadgets.panes ui.gadgets.scrollers
ui.gadgets.tracks ui.gestures ui.gadgets.buttons ; ui.gadgets.tracks ui.gestures ui.gadgets.buttons ;
IN: ui.tools.profiler IN: ui.tools.profiler
TUPLE: profiler-gadget pane ; TUPLE: profiler-gadget < track pane ;
: <profiler-gadget> ( -- gadget ) : <profiler-gadget> ( -- gadget )
profiler-gadget new { 0 1 } profiler-gadget new-track
[ [
toolbar, [
<pane> g-> set-profiler-gadget-pane toolbar,
<scroller> 1 track, <pane> g-> set-profiler-gadget-pane
] { 0 1 } build-track ; <scroller> 1 track,
] with-gadget
] keep ;
: with-profiler-pane ( gadget quot -- ) : with-profiler-pane ( gadget quot -- )
>r profiler-gadget-pane r> with-pane ; >r profiler-gadget-pane r> with-pane ;

18
extra/ui/tools/search/search.factor
View File

@ -11,7 +11,7 @@ vocabs words vocabs.loader tools.vocabs unicode.case calendar ui
; ;
IN: ui.tools.search IN: ui.tools.search
TUPLE: live-search field list ; TUPLE: live-search < track field list ;
: search-value ( live-search -- value ) : search-value ( live-search -- value )
live-search-list list-value ; live-search-list list-value ;
@ -34,10 +34,10 @@ M: live-search handle-gesture* ( gadget gesture delegate -- ? )
: find-search-list ( gadget -- list ) : find-search-list ( gadget -- list )
find-live-search live-search-list ; find-live-search live-search-list ;
TUPLE: search-field ; TUPLE: search-field < editor ;
: <search-field> ( -- gadget ) : <search-field> ( -- gadget )
<editor> search-field construct-editor ; search-field new-editor ;
search-field H{ search-field H{
{ T{ key-down f f "UP" } [ find-search-list select-previous ] } { T{ key-down f f "UP" } [ find-search-list select-previous ] }
@ -60,12 +60,14 @@ search-field H{
swap <list> ; swap <list> ;
: <live-search> ( string seq limited? presenter -- gadget ) : <live-search> ( string seq limited? presenter -- gadget )
live-search new { 0 1 } live-search new-track
[ [
<search-field> g-> set-live-search-field f track, [
<search-list> g-> set-live-search-list <search-field> g-> set-live-search-field f track,
<scroller> 1 track, <search-list> g-> set-live-search-list
] { 0 1 } build-track <scroller> 1 track,
] with-gadget
] keep
[ live-search-field set-editor-string ] keep [ live-search-field set-editor-string ] keep
[ live-search-field end-of-document ] keep ; [ live-search-field end-of-document ] keep ;

8
extra/ui/tools/tools.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2006, 2008 Slava Pestov. ! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs debugger ui.tools.workspace USING: accessors arrays assocs debugger ui.tools.workspace
ui.tools.operations ui.tools.traceback ui.tools.browser ui.tools.operations ui.tools.traceback ui.tools.browser
ui.tools.inspector ui.tools.listener ui.tools.profiler ui.tools.inspector ui.tools.listener ui.tools.profiler
ui.tools.operations inspector io kernel math models namespaces ui.tools.operations inspector io kernel math models namespaces
@ -14,7 +14,7 @@ IN: ui.tools
: <workspace-tabs> ( -- tabs ) : <workspace-tabs> ( -- tabs )
g gadget-model g gadget-model
"tool-switching" workspace command-map "tool-switching" workspace command-map commands>>
[ command-string ] { } assoc>map <enum> >alist [ command-string ] { } assoc>map <enum> >alist
<toggle-buttons> ; <toggle-buttons> ;
@ -27,7 +27,9 @@ IN: ui.tools
] { } make g gadget-model <book> ; ] { } make g gadget-model <book> ;
: <workspace> ( -- workspace ) : <workspace> ( -- workspace )
0 <model> { 0 1 } <track> workspace construct-control [ { 0 1 } workspace new-track
0 <model> >>model
[
[ [
<listener-gadget> g set-workspace-listener <listener-gadget> g set-workspace-listener
<workspace-book> g set-workspace-book <workspace-book> g set-workspace-book

22
extra/ui/tools/traceback/traceback.factor
View File

@ -1,10 +1,10 @@
! Copyright (C) 2006, 2008 Slava Pestov. ! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: continuations kernel models namespaces prettyprint ui USING: accessors continuations kernel models namespaces
ui.commands ui.gadgets ui.gadgets.labelled assocs prettyprint ui ui.commands ui.gadgets ui.gadgets.labelled assocs
ui.gadgets.tracks ui.gadgets.buttons ui.gadgets.panes ui.gadgets.tracks ui.gadgets.buttons ui.gadgets.panes
ui.gadgets.status-bar ui.gadgets.scrollers ui.gadgets.status-bar ui.gadgets.scrollers ui.gestures sequences
ui.gestures sequences hashtables inspector ; hashtables inspector ;
IN: ui.tools.traceback IN: ui.tools.traceback
: <callstack-display> ( model -- gadget ) : <callstack-display> ( model -- gadget )
@ -19,12 +19,14 @@ IN: ui.tools.traceback
[ [ continuation-retain stack. ] when* ] [ [ continuation-retain stack. ] when* ]
t "Retain stack" <labelled-pane> ; t "Retain stack" <labelled-pane> ;
TUPLE: traceback-gadget ; TUPLE: traceback-gadget < track ;
M: traceback-gadget pref-dim* drop { 550 600 } ; M: traceback-gadget pref-dim* drop { 550 600 } ;
: <traceback-gadget> ( model -- gadget ) : <traceback-gadget> ( model -- gadget )
{ 0 1 } <track> traceback-gadget construct-control [ { 0 1 } traceback-gadget new-track
swap >>model
[
[ [
[ [
g gadget-model <datastack-display> 1/2 track, g gadget-model <datastack-display> 1/2 track,
@ -39,14 +41,8 @@ M: traceback-gadget pref-dim* drop { 550 600 } ;
[ [ continuation-name namestack. ] when* ] [ [ continuation-name namestack. ] when* ]
<pane-control> ; <pane-control> ;
TUPLE: variables-gadget ;
: <variables-gadget> ( model -- gadget ) : <variables-gadget> ( model -- gadget )
<namestack-display> <scroller> <namestack-display> { 400 400 } <limited-scroller> ;
variables-gadget new
[ set-gadget-delegate ] keep ;
M: variables-gadget pref-dim* drop { 400 400 } ;
: variables ( traceback -- ) : variables ( traceback -- )
gadget-model <variables-gadget> gadget-model <variables-gadget>

44
extra/ui/tools/walker/walker.factor
View File

@ -1,22 +1,24 @@
! Copyright (C) 2006, 2008 Slava Pestov. ! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel concurrency.messaging inspector ui.tools.listener USING: accessors kernel concurrency.messaging inspector
ui.tools.traceback ui.gadgets.buttons ui.gadgets.status-bar ui.tools.listener ui.tools.traceback ui.gadgets.buttons
ui.gadgets.tracks ui.commands ui.gadgets models models.filter ui.gadgets.status-bar ui.gadgets.tracks ui.commands ui.gadgets
ui.tools.workspace ui.gestures ui.gadgets.labels ui threads models models.filter ui.tools.workspace ui.gestures
namespaces tools.walker assocs combinators ; ui.gadgets.labels ui threads namespaces tools.walker assocs
combinators ;
IN: ui.tools.walker IN: ui.tools.walker
TUPLE: walker-gadget TUPLE: walker-gadget < track
status continuation thread status continuation thread
traceback traceback
closing? ; closing? ;
: walker-command ( walker msg -- ) : walker-command ( walker msg -- )
swap swap
dup walker-gadget-thread thread-registered? dup thread>> thread-registered?
[ walker-gadget-thread send-synchronous drop ] [ thread>> send-synchronous drop ]
[ 2drop ] if ; [ 2drop ]
if ;
: com-step ( walker -- ) step walker-command ; : com-step ( walker -- ) step walker-command ;
@ -31,12 +33,10 @@ closing? ;
: com-abandon ( walker -- ) abandon walker-command ; : com-abandon ( walker -- ) abandon walker-command ;
M: walker-gadget ungraft* M: walker-gadget ungraft*
[ t swap set-walker-gadget-closing? ] [ t >>closing? drop ] [ com-continue ] [ call-next-method ] tri ;
[ com-continue ]
[ delegate ungraft* ] tri ;
M: walker-gadget focusable-child* M: walker-gadget focusable-child*
walker-gadget-traceback ; traceback>> ;
: walker-state-string ( status thread -- string ) : walker-state-string ( status thread -- string )
[ [
@ -56,11 +56,17 @@ M: walker-gadget focusable-child*
[ walker-state-string ] curry <filter> <label-control> ; [ walker-state-string ] curry <filter> <label-control> ;
: <walker-gadget> ( status continuation thread -- gadget ) : <walker-gadget> ( status continuation thread -- gadget )
over <traceback-gadget> f walker-gadget boa [ { 0 1 } walker-gadget new-track
toolbar, swap >>thread
g walker-gadget-status self <thread-status> f track, swap >>continuation
g walker-gadget-traceback 1 track, swap >>status
] { 0 1 } build-track ; [
[
toolbar,
g status>> self <thread-status> f track,
g continuation>> <traceback-gadget> 1 track,
] with-gadget
] keep ;
: walker-help ( -- ) "ui-walker" help-window ; : walker-help ( -- ) "ui-walker" help-window ;
@ -81,7 +87,7 @@ walker-gadget "toolbar" f {
{ {
{ [ dup walker-gadget? not ] [ 2drop f ] } { [ dup walker-gadget? not ] [ 2drop f ] }
{ [ dup walker-gadget-closing? ] [ 2drop f ] } { [ dup walker-gadget-closing? ] [ 2drop f ] }
[ walker-gadget-thread eq? ] [ thread>> eq? ]
} cond ; } cond ;
: find-walker-window ( thread -- world/f ) : find-walker-window ( thread -- world/f )

4
extra/ui/tools/workspace/workspace.factor
View File

@ -8,7 +8,7 @@ ui.gadgets.worlds ui.gadgets.presentations ui.gadgets.status-bar
ui.commands ui.gestures assocs arrays namespaces accessors ; ui.commands ui.gestures assocs arrays namespaces accessors ;
IN: ui.tools.workspace IN: ui.tools.workspace
TUPLE: workspace book listener popup ; TUPLE: workspace < track book listener popup ;
: find-workspace ( gadget -- workspace ) : find-workspace ( gadget -- workspace )
[ workspace? ] find-parent ; [ workspace? ] find-parent ;
@ -52,7 +52,7 @@ M: gadget tool-scroller drop f ;
: help-window ( topic -- ) : help-window ( topic -- )
[ [
<pane> [ [ help ] with-pane ] keep <pane> [ [ help ] with-pane ] keep
<limited-scroller> { 550 700 } >>dim { 550 700 } <limited-scroller>
] keep ] keep
article-title open-window ; article-title open-window ;

104
extra/ui/ui-docs.factor
View File

@ -1,8 +1,6 @@
USING: ui.gadgets.worlds ui.gadgets ui.backend help.markup USING: help.markup help.syntax strings quotations debugger
help.syntax strings quotations debugger io.styles namespaces io.styles namespaces ui.backend ui.gadgets ui.gadgets.worlds
ui.gadgets.tracks ui.gadgets.packs ui.gadgets.grids ui.gadgets.tracks ui.gadgets.packs ui.gadgets.grids ;
ui.gadgets.frames ui.gadgets.books ui.gadgets.panes
ui.gadgets.incremental ;
IN: ui IN: ui
HELP: windows HELP: windows
@ -239,103 +237,17 @@ $nl
{ $subsection make-gadget } { $subsection make-gadget }
"Words such as " { $link gadget, } " and " { $link track, } " access the gadget through the " { $link make-gadget } " variable." "Words such as " { $link gadget, } " and " { $link track, } " access the gadget through the " { $link make-gadget } " variable."
$nl $nl
"Combinators whose names are prefixed with " { $snippet "build-" } " take a tuple as input, and construct a new gadget which the tuple will delegate to. The primitive combinator used to define all combinators of this form:" "A combinator which stores a gadget in the " { $link gadget } " variable:"
{ $subsection build-gadget }
"In this case, the new gadget is stored in both the " { $link make-gadget } " and " { $link gadget } " variables."
$nl
"A combinator which stores a gadget in the " { $link gadget } " variable; it is used by " { $link build-gadget } ":"
{ $subsection with-gadget } { $subsection with-gadget }
"The following words access the " { $link gadget } " variable; they can be used from " { $link with-gadget } " and " { $link build-gadget } " to store child gadgets in tuple slots:" "The following words access the " { $link gadget } " variable; they can be used from " { $link with-gadget } " to store child gadgets in tuple slots:"
{ $subsection g } { $subsection g }
{ $subsection g-> } ; { $subsection g-> } ;
ARTICLE: "ui-pack-layout" "Pack layouts"
"Pack gadgets layout their children along a single axis."
{ $subsection pack }
"Creating empty packs:"
{ $subsection <pack> }
{ $subsection <pile> }
{ $subsection <shelf> }
"Creating packs using a combinator:"
{ $subsection make-pile }
{ $subsection make-filled-pile }
{ $subsection make-shelf }
{ $subsection gadget, }
"For more control, custom layouts can reuse portions of pack layout logic:"
{ $subsection pack-pref-dim }
{ $subsection pack-layout } ;
ARTICLE: "ui-track-layout" "Track layouts"
"Track gadgets are like " { $link "ui-pack-layout" } " except each child is resized to a fixed multiple of the track's dimension."
{ $subsection track }
"Creating empty tracks:"
{ $subsection <track> }
"Adding children:"
{ $subsection track-add }
"Creating new tracks using a combinator:"
{ $subsection make-track }
{ $subsection build-track }
{ $subsection track, }
"New gadgets can be defined which delegate to tracks for layout:"
{ $subsection build-track } ;
ARTICLE: "ui-grid-layout" "Grid layouts"
"Grid gadgets layout their children in a rectangular grid."
{ $subsection grid }
"Creating grids from a fixed set of gadgets:"
{ $subsection <grid> }
"Managing chidren:"
{ $subsection grid-add }
{ $subsection grid-remove }
{ $subsection grid-child } ;
ARTICLE: "ui-frame-layout" "Frame layouts"
"Frames resemble " { $link "ui-grid-layout" } " except the size of grid is fixed at 3x3, and the center gadget fills up any available space. Because frames delegate to grids, grid layout words can be used to add and remove children."
{ $subsection frame }
"Creating empty frames:"
{ $subsection <frame> }
"Creating new frames using a combinator:"
{ $subsection make-frame }
{ $subsection build-frame }
{ $subsection frame, }
"New gadgets can be defined which delegate to frames for layout:"
{ $subsection build-frame }
"A set of mnemonic words for the positions on a frame's 3x3 grid; these words push values which may be passed to " { $link grid-add } " or " { $link frame, } ":"
{ $subsection @center }
{ $subsection @left }
{ $subsection @right }
{ $subsection @top }
{ $subsection @bottom }
{ $subsection @top-left }
{ $subsection @top-right }
{ $subsection @bottom-left }
{ $subsection @bottom-right } ;
ARTICLE: "ui-book-layout" "Book layouts"
"Books can contain any number of children, and display one child at a time."
{ $subsection book }
{ $subsection <book> } ;
ARTICLE: "ui-null-layout" "Manual layouts" ARTICLE: "ui-null-layout" "Manual layouts"
"When automatic layout is not appropriate, gadgets can be added to a parent with no layout policy, and then positioned and sized manually:" "When automatic layout is not appropriate, gadgets can be added to a parent with no layout policy, and then positioned and sized manually:"
{ $subsection set-rect-loc } { $subsection set-rect-loc }
{ $subsection set-gadget-dim } ; { $subsection set-gadget-dim } ;
ARTICLE: "ui-incremental-layout" "Incremental layouts"
"Incremental layout gadgets are like " { $link "ui-pack-layout" } " except the relayout operation after adding a new child can be done in constant time."
$nl
"With all layouts, relayout requests from consecutive additions and removals are of children are coalesced and result in only one relayout operation being performed, however the run time of the relayout operation itself depends on the number of children."
$nl
"Incremental layout is used by " { $link pane } " gadgets to ensure that new lines of output does not take longer to display when the pane already has previous output."
$nl
"Incremental layouts are not a general replacement for " { $link "ui-pack-layout" } " and there are some limitations to be aware of."
{ $subsection incremental }
{ $subsection <incremental> }
"Children are added and removed with a special set of words which perform necessary relayout immediately:"
{ $subsection add-incremental }
{ $subsection clear-incremental }
"Calling " { $link unparent } " to remove a child of an incremental layout is permitted, however the relayout following the removal will not be performed in constant time, because all gadgets following the removed gadget need to be moved." ;
ARTICLE: "ui-layout-impl" "Implementing layout gadgets" ARTICLE: "ui-layout-impl" "Implementing layout gadgets"
"The relayout process proceeds top-down, with parents laying out their children, which in turn lay out their children. Custom layout policy is implemented by defining a method on a generic word:" "The relayout process proceeds top-down, with parents laying out their children, which in turn lay out their children. Custom layout policy is implemented by defining a method on a generic word:"
{ $subsection layout* } { $subsection layout* }
@ -359,10 +271,8 @@ ARTICLE: "new-gadgets" "Implementing new gadgets"
$nl $nl
"Bare gadgets can be constructed directly, which is useful if all you need is a custom appearance with no further behavior (see " { $link "ui-pen-protocol" } "):" "Bare gadgets can be constructed directly, which is useful if all you need is a custom appearance with no further behavior (see " { $link "ui-pen-protocol" } "):"
{ $subsection <gadget> } { $subsection <gadget> }
"You can construct a new tuple which delegates to a bare gadget:" "New gadgets are defined as subclasses of an existing gadget type, perhaps even " { $link gadget } " itself. A parametrized constructor should be used to construct subclasses:"
{ $subsection construct-gadget } { $subsection new-gadget }
"You can also delegate a tuple to an existing gadget:"
{ $subsection set-gadget-delegate }
"Further topics:" "Further topics:"
{ $subsection "ui-gestures" } { $subsection "ui-gestures" }
{ $subsection "ui-paint" } { $subsection "ui-paint" }

1
extra/ui/ui.factor
View File

@ -175,7 +175,6 @@ SYMBOL: ui-thread
dup pref-dim over set-gadget-dim dup relayout graft ; dup pref-dim over set-gadget-dim dup relayout graft ;
: open-window ( gadget title -- ) : open-window ( gadget title -- )
>r [ 1 track, ] { 0 1 } make-track r>
f <world> open-world-window ; f <world> open-world-window ;
: set-fullscreen? ( ? gadget -- ) : set-fullscreen? ( ? gadget -- )

4
extra/ui/windows/windows.factor
View File

@ -98,7 +98,7 @@ SYMBOLS: msg-obj class-name-ptr mouse-captured ;
: handle-wm-move ( hWnd uMsg wParam lParam -- ) : handle-wm-move ( hWnd uMsg wParam lParam -- )
2nip 2nip
[ lo-word ] keep hi-word 2array [ lo-word ] keep hi-word 2array
swap window set-world-loc ; swap window (>>window-loc) ;
: wm-keydown-codes ( -- key ) : wm-keydown-codes ( -- key )
H{ H{
@ -420,7 +420,7 @@ M: windows-ui-backend do-events
style 0 ex-style AdjustWindowRectEx win32-error=0/f ; style 0 ex-style AdjustWindowRectEx win32-error=0/f ;
: make-RECT ( world -- RECT ) : make-RECT ( world -- RECT )
dup world-loc { 40 40 } vmax dup rot rect-dim v+ dup window-loc>> { 40 40 } vmax dup rot rect-dim v+
"RECT" <c-object> "RECT" <c-object>
over first over set-RECT-right over first over set-RECT-right
swap second over set-RECT-bottom swap second over set-RECT-bottom

4
extra/ui/x11/x11.factor
View File

@ -21,7 +21,7 @@ C: <x11-handle> x11-handle
M: world expose-event nip relayout ; M: world expose-event nip relayout ;
M: world configure-event M: world configure-event
over configured-loc over set-world-loc over configured-loc over (>>window-loc)
swap configured-dim over set-gadget-dim swap configured-dim over set-gadget-dim
! In case dimensions didn't change ! In case dimensions didn't change
relayout-1 ; relayout-1 ;
@ -170,7 +170,7 @@ M: world client-event
swap close-box? [ ungraft ] [ drop ] if ; swap close-box? [ ungraft ] [ drop ] if ;
: gadget-window ( world -- ) : gadget-window ( world -- )
dup world-loc over rect-dim glx-window dup window-loc>> over rect-dim glx-window
over "Factor" create-xic <x11-handle> over "Factor" create-xic <x11-handle>
2dup x11-handle-window register-window 2dup x11-handle-window register-window
swap set-world-handle ; swap set-world-handle ;

28
extra/xmode/keyword-map/keyword-map.factor
View File

@ -1,37 +1,43 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel strings assocs sequences hashtables USING: accessors kernel strings assocs sequences hashtables
sorting unicode.case unicode.categories sets ; sorting unicode.case unicode.categories sets ;
IN: xmode.keyword-map IN: xmode.keyword-map
! Based on org.gjt.sp.jedit.syntax.KeywordMap ! Based on org.gjt.sp.jedit.syntax.KeywordMap
TUPLE: keyword-map no-word-sep ignore-case? ; TUPLE: keyword-map no-word-sep ignore-case? assoc ;
: <keyword-map> ( ignore-case? -- map ) : <keyword-map> ( ignore-case? -- map )
H{ } clone { set-keyword-map-ignore-case? set-delegate } keyword-map new
keyword-map construct ; swap >>ignore-case?
H{ } clone >>assoc ;
: invalid-no-word-sep ( keyword-map -- ) f >>no-word-sep drop ; : invalid-no-word-sep ( keyword-map -- ) f >>no-word-sep drop ;
: handle-case ( key keyword-map -- key assoc ) : handle-case ( key keyword-map -- key assoc )
[ keyword-map-ignore-case? [ >upper ] when ] keep [ ignore-case?>> [ >upper ] when ] [ assoc>> ] bi ;
delegate ;
M: keyword-map assoc-size
assoc>> assoc-size ;
M: keyword-map at* handle-case at* ; M: keyword-map at* handle-case at* ;
M: keyword-map set-at M: keyword-map set-at
[ handle-case set-at ] keep invalid-no-word-sep ; [ handle-case set-at ] [ invalid-no-word-sep ] bi ;
M: keyword-map clear-assoc M: keyword-map clear-assoc
[ delegate clear-assoc ] keep invalid-no-word-sep ; [ assoc>> clear-assoc ] [ invalid-no-word-sep ] bi ;
M: keyword-map >alist delegate >alist ; M: keyword-map >alist
assoc>> >alist ;
: (keyword-map-no-word-sep) ( assoc -- str ) : (keyword-map-no-word-sep) ( assoc -- str )
keys concat [ alpha? not ] filter prune natural-sort ; keys concat [ alpha? not ] filter prune natural-sort ;
: keyword-map-no-word-sep* ( keyword-map -- str ) : keyword-map-no-word-sep* ( keyword-map -- str )
dup keyword-map-no-word-sep [ ] [ dup no-word-sep>> [ ] [
dup (keyword-map-no-word-sep) dup (keyword-map-no-word-sep) >>no-word-sep
dup rot set-keyword-map-no-word-sep keyword-map-no-word-sep*
] ?if ; ] ?if ;
INSTANCE: keyword-map assoc INSTANCE: keyword-map assoc