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

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

db4
Bruno Deferrari 2008-07-11 01:18:16 -03:00
parent aec887cc14 82a0a3c5c4
commit e5c3c05c4d
54 changed files with 912 additions and 875 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

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

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

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)
] ]
} }

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 ;

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

@ -1,15 +1,16 @@
! 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 fill ;
: <border> ( child gap -- border ) : <border> ( child gap -- border )
dup 2array { 0 0 } border boa border new-gadget
<gadget> over set-delegate swap dup 2array >>size
tuck add-gadget ; { 0 0 } >>fill
[ add-gadget ] keep ;
M: border pref-dim* M: border pref-dim*
[ border-size 2 v*n ] keep [ border-size 2 v*n ] keep

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

75
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
ui.gadgets.labels ui.gadgets.theme 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.wrappers
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 < wrapper pressed? selected? quot ;
: buttons-down? ( -- ? ) : buttons-down? ( -- ? )
hand-buttons get-global empty? not ; hand-buttons get-global empty? not ;
@ -39,10 +40,13 @@ button H{
{ T{ mouse-enter } [ button-update ] } { T{ mouse-enter } [ button-update ] }
} set-gestures } set-gestures
: new-button ( label quot class -- button )
new-gadget
swap >>quot
[ >r >label r> add-gadget ] keep ; inline
: <button> ( gadget quot -- button ) : <button> ( gadget quot -- button )
button new button new-button ;
swap >>quot
[ set-gadget-delegate ] keep ;
TUPLE: button-paint plain rollover pressed selected ; TUPLE: button-paint plain rollover pressed selected ;
@ -69,7 +73,7 @@ M: button-paint draw-boundary
f black <solid> dup f <button-paint> >>boundary ; inline f black <solid> dup f <button-paint> >>boundary ; 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
@ -82,11 +86,13 @@ M: button-paint draw-boundary
<bevel-button-paint> >>interior <bevel-button-paint> >>interior
faint-boundary ; inline faint-boundary ; inline
: <bevel-button> ( label quot -- button ) : >bevel-label ( label -- gadget )
>r >label 5 <border> r> >label 5 <border> ;
<button> bevel-button-theme ;
TUPLE: repeat-button ; : <bevel-button> ( label quot -- button )
>r >bevel-label r> <button> bevel-button-theme ;
TUPLE: repeat-button < button ;
repeat-button H{ repeat-button H{
{ T{ drag } [ button-clicked ] } { T{ drag } [ button-clicked ] }
@ -95,8 +101,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 >r >bevel-label r> 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 +133,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 +176,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 +194,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 +209,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> ; >bevel-label <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 ;

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

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

@ -1,14 +1,14 @@
! 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 self
font color caret-color selection-color font color caret-color selection-color
caret mark caret mark
@ -16,28 +16,25 @@ 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
dup dup set-editor-self ; 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
@ -474,10 +471,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 +482,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 ;

8
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
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 } "." } ;
@ -261,33 +254,7 @@ 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 build-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 +265,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*

25
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,15 +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 ) : construct-gadget ( class -- tuple )
>r <gadget> r> construct-delegate ; inline >r <gadget> r> construct-delegate ; inline
@ -142,10 +145,6 @@ M: gadget children-on nip gadget-children ;
dup pick [ set-gadget-parent ] with each-child dup pick [ set-gadget-parent ] with each-child
] when set-delegate ; ] 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 -- ? )

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

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

@ -57,8 +57,3 @@ TUPLE: closable-gadget content ;
] build-frame ; ] build-frame ;
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.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> ;

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

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

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

@ -13,10 +13,10 @@ TUPLE: word-break-gadget ;
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 ;

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

@ -1,13 +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: arrays definitions ui.gadgets ui.gadgets.borders USING: arrays accessors definitions ui.gadgets ui.gadgets.borders
ui.gadgets.buttons ui.gadgets.labels ui.gadgets.menus ui.gadgets.buttons ui.gadgets.labels ui.gadgets.menus
ui.gadgets.worlds hashtables io kernel prettyprint sequences ui.gadgets.worlds hashtables io kernel prettyprint sequences
strings io.styles words help math models namespaces quotations strings io.styles words help math models namespaces quotations
ui.commands ui.operations ui.gestures ; 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 +25,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 ;

23
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 ;
@ -88,7 +88,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 )
"..." "..."
@ -118,8 +118,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 ;

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 ;

18
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 -- 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 }

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 ;

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

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 ;

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." } ;

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

@ -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.factor
View File

@ -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. ( -- )

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

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

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

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 ;

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

@ -359,10 +359,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 ;