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 )
<x-slider> 1 over set-slider-line ;
TUPLE: color-preview ;
TUPLE: color-preview < gadget ;
: <color-preview> ( model -- gadget )
<gadget> color-preview construct-control
color-preview new-gadget
{ 100 100 } over set-rect-dim ;
M: color-preview model-changed

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

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

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

@ -4,31 +4,31 @@ USING: kernel tools.test peg fjsc ;
IN: fjsc.tests
{ 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
{ 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
{ 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
{ 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
{ 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
{ 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
{ T{ ast-stack-effect f V{ } V{ } } } [
"( -- )" 'stack-effect' parse parse-result-ast
"( -- )" 'stack-effect' parse
] unit-test
{ f } [
@ -37,18 +37,18 @@ IN: fjsc.tests
{ T{ ast-expression f V{ T{ ast-string f "abcd" } } } } [
"\"abcd\"" 'statement' parse parse-result-ast
"\"abcd\"" 'statement' parse
] unit-test
{ T{ ast-expression f V{ T{ ast-use f "foo" } } } } [
"USE: foo" 'statement' parse parse-result-ast
"USE: foo" 'statement' parse
] unit-test
{ T{ ast-expression f V{ T{ ast-in f "foo" } } } } [
"IN: foo" 'statement' parse parse-result-ast
"IN: foo" 'statement' parse
] unit-test
{ 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

165
extra/fjsc/fjsc.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2006 Chris Double. All Rights Reserved.
! 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
io.streams.string assocs memoize ascii peg.parsers ;
io.streams.string assocs ascii peg.parsers accessors ;
IN: fjsc
TUPLE: ast-number value ;
@ -20,28 +20,13 @@ TUPLE: ast-using names ;
TUPLE: ast-in name ;
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 )
[ blank? not ] keep
[ "}];\"" member? not ] keep
digit? not
and and ;
MEMO: 'identifier-ends' ( -- parser )
: 'identifier-ends' ( -- parser )
[
[ blank? not ] keep
[ CHAR: " = not ] keep
@ -52,22 +37,22 @@ MEMO: 'identifier-ends' ( -- parser )
and and and and and
] satisfy repeat0 ;
MEMO: 'identifier-middle' ( -- parser )
: 'identifier-middle' ( -- parser )
[ identifier-middle? ] satisfy repeat1 ;
MEMO: 'identifier' ( -- parser )
: 'identifier' ( -- parser )
[
'identifier-ends' ,
'identifier-middle' ,
'identifier-ends' ,
] { } make seq [
concat >string f <ast-identifier>
] seq* [
concat >string f ast-identifier boa
] action ;
DEFER: 'expression'
MEMO: 'effect-name' ( -- parser )
: 'effect-name' ( -- parser )
[
[ blank? not ] keep
[ CHAR: ) = not ] keep
@ -75,98 +60,98 @@ MEMO: 'effect-name' ( -- parser )
and and
] satisfy repeat1 [ >string ] action ;
MEMO: 'stack-effect' ( -- parser )
: 'stack-effect' ( -- parser )
[
"(" token hide ,
'effect-name' sp repeat0 ,
"--" token sp hide ,
'effect-name' sp repeat0 ,
")" token sp hide ,
] { } make seq [
first2 <ast-stack-effect>
] seq* [
first2 ast-stack-effect boa
] action ;
MEMO: 'define' ( -- parser )
: 'define' ( -- parser )
[
":" token sp hide ,
'identifier' sp [ ast-identifier-value ] action ,
'identifier' sp [ value>> ] action ,
'stack-effect' sp optional ,
'expression' ,
";" token sp hide ,
] { } make seq [ first3 <ast-define> ] action ;
] seq* [ first3 ast-define boa ] action ;
MEMO: 'quotation' ( -- parser )
: 'quotation' ( -- parser )
[
"[" token sp hide ,
'expression' [ ast-expression-values ] action ,
'expression' [ values>> ] action ,
"]" token sp hide ,
] { } make seq [ first <ast-quotation> ] action ;
] seq* [ first ast-quotation boa ] action ;
MEMO: 'array' ( -- parser )
: 'array' ( -- parser )
[
"{" token sp hide ,
'expression' [ ast-expression-values ] action ,
'expression' [ values>> ] action ,
"}" token sp hide ,
] { } make seq [ first <ast-array> ] action ;
] seq* [ first ast-array boa ] action ;
MEMO: 'word' ( -- parser )
: 'word' ( -- parser )
[
"\\" token sp hide ,
'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' ,
'integer' [ <ast-number> ] action ,
'string' [ <ast-string> ] action ,
] { } make choice ;
'integer' [ ast-number boa ] action ,
'string' [ ast-string boa ] action ,
] choice* ;
MEMO: 'comment' ( -- parser )
: 'comment' ( -- parser )
[
[
"#!" token sp ,
"!" token sp ,
] { } make choice hide ,
] choice* hide ,
[
dup CHAR: \n = swap CHAR: \r = or not
] satisfy repeat0 ,
] { } make seq [ drop <ast-comment> ] action ;
] seq* [ drop ast-comment boa ] action ;
MEMO: 'USE:' ( -- parser )
: 'USE:' ( -- parser )
[
"USE:" token sp hide ,
'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 ,
'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 ,
'identifier' sp [ ast-identifier-value ] action repeat1 ,
'identifier' sp [ value>> ] action repeat1 ,
";" token sp hide ,
] { } make seq [ first <ast-using> ] action ;
] seq* [ first ast-using boa ] action ;
MEMO: 'hashtable' ( -- parser )
: 'hashtable' ( -- parser )
[
"H{" token sp hide ,
'expression' [ ast-expression-values ] action ,
'expression' [ values>> ] action ,
"}" token sp hide ,
] { } make seq [ first <ast-hashtable> ] action ;
] seq* [ first ast-hashtable boa ] action ;
MEMO: 'parsing-word' ( -- parser )
: 'parsing-word' ( -- parser )
[
'USE:' ,
'USING:' ,
'IN:' ,
] { } make choice ;
] choice* ;
MEMO: 'expression' ( -- parser )
: 'expression' ( -- parser )
[
[
'comment' ,
@ -177,17 +162,17 @@ MEMO: 'expression' ( -- parser )
'hashtable' sp ,
'word' sp ,
'atom' sp ,
] { } make choice repeat0 [ <ast-expression> ] action
] choice* repeat0 [ ast-expression boa ] action
] delay ;
MEMO: 'statement' ( -- parser )
: 'statement' ( -- parser )
'expression' ;
GENERIC: (compile) ( ast -- )
GENERIC: (literal) ( ast -- )
M: ast-number (literal)
ast-number-value number>string , ;
value>> number>string , ;
M: ast-number (compile)
"factor.push_data(" ,
@ -196,7 +181,7 @@ M: ast-number (compile)
M: ast-string (literal)
"\"" ,
ast-string-value ,
value>> ,
"\"" , ;
M: ast-string (compile)
@ -205,14 +190,14 @@ M: ast-string (compile)
"," , ;
M: ast-identifier (literal)
dup ast-identifier-vocab [
dup vocab>> [
"factor.get_word(\"" ,
dup ast-identifier-vocab ,
dup vocab>> ,
"\",\"" ,
ast-identifier-value ,
value>> ,
"\")" ,
] [
"factor.find_word(\"" , ast-identifier-value , "\")" ,
"factor.find_word(\"" , value>> , "\")" ,
] if ;
M: ast-identifier (compile)
@ -220,9 +205,9 @@ M: ast-identifier (compile)
M: ast-define (compile)
"factor.define_word(\"" ,
dup ast-define-name ,
dup name>> ,
"\",\"source\"," ,
ast-define-expression (compile)
expression>> (compile)
"," , ;
: do-expressions ( seq -- )
@ -242,17 +227,17 @@ M: ast-define (compile)
M: ast-quotation (literal)
"factor.make_quotation(\"source\"," ,
ast-quotation-values do-expressions
values>> do-expressions
")" , ;
M: ast-quotation (compile)
"factor.push_data(factor.make_quotation(\"source\"," ,
ast-quotation-values do-expressions
values>> do-expressions
")," , ;
M: ast-array (literal)
"[" ,
ast-array-elements [ "," , ] [ (literal) ] interleave
elements>> [ "," , ] [ (literal) ] interleave
"]" , ;
M: ast-array (compile)
@ -260,7 +245,7 @@ M: ast-array (compile)
M: ast-hashtable (literal)
"new Hashtable().fromAlist([" ,
ast-hashtable-elements [ "," , ] [ (literal) ] interleave
elements>> [ "," , ] [ (literal) ] interleave
"])" , ;
M: ast-hashtable (compile)
@ -268,22 +253,22 @@ M: ast-hashtable (compile)
M: ast-expression (literal)
ast-expression-values [
values>> [
(literal)
] each ;
M: ast-expression (compile)
ast-expression-values do-expressions ;
values>> do-expressions ;
M: ast-word (literal)
dup ast-word-vocab [
dup vocab>> [
"factor.get_word(\"" ,
dup ast-word-vocab ,
dup vocab>> ,
"\",\"" ,
ast-word-value ,
value>> ,
"\")" ,
] [
"factor.find_word(\"" , ast-word-value , "\")" ,
"factor.find_word(\"" , value>> , "\")" ,
] if ;
M: ast-word (compile)
@ -299,17 +284,17 @@ M: ast-stack-effect (compile)
M: ast-use (compile)
"factor.use(\"" ,
ast-use-name ,
name>> ,
"\"," , ;
M: ast-in (compile)
"factor.set_in(\"" ,
ast-in-name ,
name>> ,
"\"," , ;
M: ast-using (compile)
"factor.using([" ,
ast-using-names [
names>> [
"," ,
] [
"\"" , , "\"" ,
@ -319,34 +304,34 @@ M: ast-using (compile)
GENERIC: (parse-factor-quotation) ( object -- ast )
M: number (parse-factor-quotation) ( object -- ast )
<ast-number> ;
ast-number boa ;
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 )
dup name>> swap vocabulary>> <ast-identifier> ;
dup name>> swap vocabulary>> ast-identifier boa ;
M: string (parse-factor-quotation) ( object -- ast )
<ast-string> ;
ast-string boa ;
M: quotation (parse-factor-quotation) ( object -- ast )
[
[ (parse-factor-quotation) , ] each
] { } make <ast-quotation> ;
] { } make ast-quotation boa ;
M: array (parse-factor-quotation) ( object -- ast )
[
[ (parse-factor-quotation) , ] each
] { } make <ast-array> ;
] { } make ast-array boa ;
M: hashtable (parse-factor-quotation) ( object -- ast )
>alist [
[ (parse-factor-quotation) , ] each
] { } make <ast-hashtable> ;
] { } make ast-hashtable boa ;
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 )
@ -356,7 +341,7 @@ M: string fjsc-parse ( object -- ast )
M: quotation fjsc-parse ( object -- ast )
[
[ (parse-factor-quotation) , ] each
] { } make <ast-expression> ;
] { } make ast-expression boa ;
: fjsc-compile ( ast -- string )
[
@ -372,7 +357,7 @@ M: quotation fjsc-parse ( object -- ast )
: fc* ( string -- string )
[
'statement' parse parse-result-ast ast-expression-values do-expressions
'statement' parse parse-result-ast values>> do-expressions
] { } 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 ;
: lisp-string>factor ( str -- quot )
lisp-expr parse-result-ast compile-form ;
lisp-expr compile-form ;
: lisp-eval ( str -- * )
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
{ 1234 } [
"1234" "atom" \ lisp-expr rule parse parse-result-ast
"1234" "atom" \ lisp-expr rule parse
] unit-test
{ -42 } [
"-42" "atom" \ lisp-expr rule parse parse-result-ast
"-42" "atom" \ lisp-expr rule parse
] unit-test
{ 37/52 } [
"37/52" "atom" \ lisp-expr rule parse parse-result-ast
"37/52" "atom" \ lisp-expr rule parse
] unit-test
{ 123.98 } [
"123.98" "atom" \ lisp-expr rule parse parse-result-ast
"123.98" "atom" \ lisp-expr rule parse
] unit-test
{ "" } [
"\"\"" "atom" \ lisp-expr rule parse parse-result-ast
"\"\"" "atom" \ lisp-expr rule parse
] unit-test
{ "aoeu" } [
"\"aoeu\"" "atom" \ lisp-expr rule parse parse-result-ast
"\"aoeu\"" "atom" \ lisp-expr rule parse
] unit-test
{ "aoeu\"de" } [
"\"aoeu\\\"de\"" "atom" \ lisp-expr rule parse parse-result-ast
"\"aoeu\\\"de\"" "atom" \ lisp-expr rule parse
] unit-test
{ T{ lisp-symbol f "foobar" } } [
"foobar" "atom" \ lisp-expr rule parse parse-result-ast
"foobar" "atom" \ lisp-expr rule parse
] unit-test
{ T{ lisp-symbol f "+" } } [
"+" "atom" \ lisp-expr rule parse parse-result-ast
"+" "atom" \ lisp-expr rule parse
] unit-test
{ +nil+ } [
"()" lisp-expr parse-result-ast
"()" lisp-expr
] unit-test
{ T{
@ -54,7 +54,7 @@ IN: lisp.parser.tests
1
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
{ T{ cons f
@ -64,5 +64,5 @@ IN: lisp.parser.tests
T{ cons f 2 +nil+ } }
}
} [
"(1 (3 4) 2)" lisp-expr parse-result-ast
"(1 (3 4) 2)" lisp-expr
] unit-test

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

@ -17,7 +17,7 @@ TUPLE: just-parser p1 ;
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 boa wrap-peg ;

50
extra/peg/peg.factor
View File

@ -2,8 +2,9 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences strings fry namespaces math assocs shuffle debugger io
vectors arrays math.parser math.order vectors combinators combinators.lib
combinators.short-circuit classes sets unicode.categories compiler.units parser
words quotations effects memoize accessors locals effects splitting ;
classes sets unicode.categories compiler.units parser
words quotations effects memoize accessors locals effects splitting
combinators.short-circuit combinators.short-circuit.smart ;
IN: peg
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
[ 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.
#! If not, compile it to a temporary word, cache it,
#! and return it. Otherwise return the existing one.
@ -289,7 +296,7 @@ GENERIC: (compile) ( peg -- quot )
dup compiled>> [
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* ;
SYMBOL: delayed
@ -298,13 +305,13 @@ SYMBOL: delayed
#! Work through all delayed parsers and recompile their
#! words to have the correct bodies.
delayed get [
call compiled-parser 1quotation 0 1 <effect> define-declared
call compile-parser 1quotation 0 1 <effect> define-declared
] assoc-each ;
: compile ( parser -- word )
[
H{ } clone delayed [
compiled-parser fixup-delayed
compile-parser fixup-delayed
] with-variable
] with-compilation-unit ;
@ -410,17 +417,20 @@ TUPLE: seq-parser parsers ;
M: seq-parser (compile) ( peg -- quot )
[
[ 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 ;
TUPLE: choice-parser parsers ;
M: choice-parser (compile) ( peg -- quot )
[
f ,
parsers>> [ compiled-parser ] map
unclip 1quotation , \ unless* , [ 1quotation [ merge-errors ] compose , \ unless* , ] each
[
parsers>> [ compile-parser ] map
unclip 1quotation , [ 1quotation [ merge-errors ] compose , ] each
] { } make , \ || ,
] [ ] make ;
TUPLE: repeat0-parser p1 ;
@ -435,7 +445,7 @@ TUPLE: repeat0-parser p1 ;
] if* ; inline
M: repeat0-parser (compile) ( peg -- quot )
p1>> compiled-parser 1quotation '[
p1>> compile-parser 1quotation '[
input-slice V{ } clone <parse-result> , swap (repeat)
] ;
@ -449,7 +459,7 @@ TUPLE: repeat1-parser p1 ;
] if* ;
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
] ;
@ -459,7 +469,7 @@ TUPLE: optional-parser p1 ;
[ input-slice f <parse-result> ] unless* ;
M: optional-parser (compile) ( peg -- quot )
p1>> compiled-parser 1quotation '[ @ check-optional ] ;
p1>> compile-parser 1quotation '[ @ check-optional ] ;
TUPLE: semantic-parser p1 quot ;
@ -471,7 +481,7 @@ TUPLE: semantic-parser p1 quot ;
] if ; inline
M: semantic-parser (compile) ( peg -- quot )
[ p1>> compiled-parser 1quotation ] [ quot>> ] bi
[ p1>> compile-parser 1quotation ] [ quot>> ] bi
'[ @ , check-semantic ] ;
TUPLE: ensure-parser p1 ;
@ -480,7 +490,7 @@ TUPLE: ensure-parser p1 ;
[ ignore <parse-result> ] [ drop f ] if ;
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 ;
@ -488,7 +498,7 @@ TUPLE: ensure-not-parser p1 ;
[ drop f ] [ ignore <parse-result> ] if ;
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 ;
@ -500,7 +510,7 @@ TUPLE: action-parser p1 quot ;
] if ; inline
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 )
#! Return a new string without any leading whitespace
@ -512,7 +522,7 @@ M: action-parser (compile) ( peg -- quot )
TUPLE: sp-parser p1 ;
M: sp-parser (compile) ( peg -- quot )
p1>> compiled-parser 1quotation '[
p1>> compile-parser 1quotation '[
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.
#! This differs from 'delay' which calls
#! it at run time.
quot>> call compiled-parser 1quotation ;
quot>> call compile-parser 1quotation ;
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
io.styles kernel math models namespaces sequences ui ui.gadgets
ui.gadgets.books ui.gadgets.panes ui.gestures ui.render
@ -70,12 +72,10 @@ IN: slides
$divider
$list ;
TUPLE: slides ;
TUPLE: slides < book ;
: <slides> ( slides -- gadget )
[ <page> ] map 0 <model> <book>
slides construct-gadget
[ set-gadget-delegate ] keep ;
[ <page> ] map 0 <model> slides new-book ;
: change-page ( book n -- )
over control-value + over gadget-children length rem
@ -103,5 +103,3 @@ TUPLE: slides ;
: slides-window ( slides -- )
[ <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.
! See http://factorcode.org/license.txt for BSD license.
USING: math arrays cocoa cocoa.application command-line
kernel memory namespaces cocoa.messages cocoa.runtime
cocoa.subclassing cocoa.pasteboard cocoa.types cocoa.windows
cocoa.classes cocoa.application sequences system ui ui.backend
ui.clipboards ui.gadgets ui.gadgets.worlds ui.cocoa.views
core-foundation threads ;
USING: accessors math arrays cocoa cocoa.application
command-line kernel memory namespaces cocoa.messages
cocoa.runtime cocoa.subclassing cocoa.pasteboard cocoa.types
cocoa.windows cocoa.classes cocoa.application sequences system
ui ui.backend ui.clipboards ui.gadgets ui.gadgets.worlds
ui.cocoa.views core-foundation threads ;
IN: ui.cocoa
TUPLE: handle view window ;
@ -38,7 +38,7 @@ M: pasteboard set-clipboard-contents
<clipboard> selection set-global ;
: 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 -- )
[
@ -68,7 +68,7 @@ M: cocoa-ui-backend fullscreen* ( world -- ? )
world-handle handle-view -> isInFullScreenMode zero? not ;
: auto-position ( world -- )
dup world-loc { 0 0 } = [
dup window-loc>> { 0 0 } = [
world-handle handle-window -> center
] [
drop

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

@ -1,9 +1,10 @@
! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays assocs cocoa kernel math cocoa.messages
cocoa.subclassing cocoa.classes cocoa.views cocoa.application
cocoa.pasteboard cocoa.types cocoa.windows sequences ui ui.gadgets
ui.gadgets.worlds ui.gestures core-foundation threads combinators ;
USING: accessors alien alien.c-types arrays assocs cocoa kernel
math cocoa.messages cocoa.subclassing cocoa.classes cocoa.views
cocoa.application cocoa.pasteboard cocoa.types cocoa.windows
sequences ui ui.gadgets ui.gadgets.worlds ui.gestures
core-foundation threads combinators ;
IN: ui.cocoa.views
: send-mouse-moved ( view event -- )
@ -377,7 +378,7 @@ CLASS: {
[
2nip -> object
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.
USING: kernel sequences models ui.gadgets ;
USING: accessors kernel sequences models ui.gadgets ;
IN: ui.gadgets.books
TUPLE: book ;
TUPLE: book < gadget ;
: hide-all ( book -- ) gadget-children [ hide-gadget ] each ;
@ -16,8 +16,13 @@ M: book model-changed
dup current-page show-gadget
relayout ;
: new-book ( pages model class -- book )
new-gadget
swap >>model
[ add-gadgets ] keep ; inline
: <book> ( pages model -- book )
<gadget> book construct-control [ add-gadgets ] keep ;
book new-book ;
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.
USING: arrays ui.gadgets generic hashtables kernel math
USING: accessors arrays ui.gadgets kernel math
namespaces vectors sequences math.vectors ;
IN: ui.gadgets.borders
TUPLE: border size fill ;
TUPLE: border < gadget size fill ;
: <border> ( child gap -- border )
dup 2array { 0 0 } border boa
<gadget> over set-delegate
tuck add-gadget ;
border new-gadget
swap dup 2array >>size
{ 0 0 } >>fill
[ add-gadget ] keep ;
M: border pref-dim*
[ 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
[ 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> {

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

@ -1,14 +1,15 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays ui.commands ui.gadgets ui.gadgets.borders
ui.gadgets.labels ui.gadgets.theme
USING: accessors arrays kernel math models namespaces sequences
strings quotations assocs combinators classes colors
classes.tuple opengl math.vectors
ui.commands ui.gadgets ui.gadgets.borders
ui.gadgets.labels ui.gadgets.theme ui.gadgets.wrappers
ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures
ui.render kernel math models namespaces sequences strings
quotations assocs combinators classes colors classes.tuple
opengl math.vectors ;
ui.render ;
IN: ui.gadgets.buttons
TUPLE: button pressed? selected? quot ;
TUPLE: button < wrapper pressed? selected? quot ;
: buttons-down? ( -- ? )
hand-buttons get-global empty? not ;
@ -39,10 +40,13 @@ button H{
{ T{ mouse-enter } [ button-update ] }
} set-gestures
: <button> ( gadget quot -- button )
button new
: new-button ( label quot class -- button )
new-gadget
swap >>quot
[ set-gadget-delegate ] keep ;
[ >r >label r> add-gadget ] keep ; inline
: <button> ( gadget quot -- button )
button new-button ;
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
: <roll-button> ( label quot -- button )
>r >label r> <button> roll-button-theme ;
<button> roll-button-theme ;
: <bevel-button-paint> ( -- paint )
plain-gradient
@ -82,11 +86,13 @@ M: button-paint draw-boundary
<bevel-button-paint> >>interior
faint-boundary ; inline
: <bevel-button> ( label quot -- button )
>r >label 5 <border> r>
<button> bevel-button-theme ;
: >bevel-label ( label -- gadget )
>label 5 <border> ;
TUPLE: repeat-button ;
: <bevel-button> ( label quot -- button )
>r >bevel-label r> <button> bevel-button-theme ;
TUPLE: repeat-button < button ;
repeat-button H{
{ T{ drag } [ button-clicked ] }
@ -95,8 +101,7 @@ repeat-button H{
: <repeat-button> ( label quot -- button )
#! Button that calls the quotation every 100ms as long as
#! the mouse is held down.
repeat-button new
[ >r <bevel-button> r> set-gadget-delegate ] keep ;
>r >bevel-label r> repeat-button new-button bevel-button-theme ;
TUPLE: checkmark-paint color ;
@ -128,20 +133,18 @@ M: checkmark-paint draw-interior
: toggle-model ( model -- )
[ not ] change-model ;
: checkbox-theme ( gadget -- )
: checkbox-theme ( gadget -- gadget )
f >>interior
{ 5 5 } >>gap
1/2 >>align
drop ;
1/2 >>align ; inline
TUPLE: checkbox ;
TUPLE: checkbox < button ;
: <checkbox> ( model label -- checkbox )
<checkmark>
label-on-right
over [ toggle-model drop ] curry <button>
checkbox construct-control
dup checkbox-theme ;
<checkmark> label-on-right checkbox-theme
[ model>> toggle-model ]
checkbox new-button
swap >>model ;
M: checkbox model-changed
swap model-value over set-button-selected? relayout-1 ;
@ -173,12 +176,13 @@ M: radio-paint draw-boundary
dup radio-knob-theme
{ 16 16 } over set-gadget-dim ;
TUPLE: radio-control value ;
TUPLE: radio-control < button value ;
: <radio-control> ( value model gadget quot -- control )
>r pick [ swap set-control-value ] curry r> call
radio-control construct-control
tuck set-radio-control-value ; inline
: <radio-control> ( value model label -- control )
[ [ value>> ] keep set-control-value ]
radio-control new-button
swap >>model
swap >>value ; inline
M: radio-control model-changed
swap model-value
@ -190,15 +194,12 @@ M: radio-control model-changed
#! quot has stack effect ( value model label -- )
swapd [ swapd call gadget, ] 2curry assoc-each ; inline
: radio-button-theme ( gadget -- )
: radio-button-theme ( gadget -- gadget )
{ 5 5 } >>gap
1/2 >>align
drop ;
1/2 >>align ; inline
: <radio-button> ( value model label -- gadget )
<radio-knob> label-on-right
[ <button> ] <radio-control>
dup radio-button-theme ;
<radio-knob> label-on-right radio-button-theme <radio-control> ;
: radio-buttons-theme ( gadget -- )
{ 5 5 } >>gap drop ;
@ -208,7 +209,7 @@ M: radio-control model-changed
dup radio-buttons-theme ;
: <toggle-button> ( value model label -- gadget )
[ <bevel-button> ] <radio-control> ;
>bevel-label <radio-control> bevel-button-theme ;
: <toggle-buttons> ( model assoc -- gadget )
[ [ <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 ;
IN: ui.gadgets.canvas
TUPLE: canvas dlist ;
TUPLE: canvas < gadget dlist ;
: <canvas> ( -- canvas )
canvas construct-gadget
canvas new-gadget
black solid-interior ;
: 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.
USING: arrays documents ui.clipboards ui.commands ui.gadgets
ui.gadgets.borders ui.gadgets.buttons ui.gadgets.labels
ui.gadgets.scrollers ui.gadgets.theme ui.render ui.gestures io
kernel math models namespaces opengl opengl.gl sequences strings
io.styles math.vectors sorting colors combinators assocs
math.order ;
USING: accessors arrays documents io kernel math models
namespaces opengl opengl.gl sequences strings io.styles
math.vectors sorting colors combinators assocs math.order
ui.clipboards ui.commands ui.gadgets ui.gadgets.borders
ui.gadgets.buttons ui.gadgets.labels ui.gadgets.scrollers
ui.gadgets.theme ui.gadgets.wrappers ui.render ui.gestures ;
IN: ui.gadgets.editors
TUPLE: editor
TUPLE: editor < gadget
self
font color caret-color selection-color
caret mark
@ -16,28 +16,25 @@ focused? ;
: <loc> ( -- loc ) { 0 0 } <model> ;
: init-editor-locs ( editor -- )
<loc> over set-editor-caret
<loc> swap set-editor-mark ;
: init-editor-locs ( editor -- editor )
<loc> >>caret
<loc> >>mark ; inline
: editor-theme ( editor -- )
black over set-editor-color
red over set-editor-caret-color
selection-color over set-editor-selection-color
monospace-font swap set-editor-font ;
: editor-theme ( editor -- editor )
black >>color
red >>caret-color
selection-color >>selection-color
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 )
<document> <gadget> editor construct-control
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
editor new-editor ;
: activate-editor-model ( editor model -- )
2dup add-connection
@ -474,10 +471,10 @@ editor "selection" f {
} define-command-map
! Multi-line editors
TUPLE: multiline-editor ;
TUPLE: multiline-editor < editor ;
: <multiline-editor> ( -- editor )
<editor> multiline-editor construct-editor ;
multiline-editor new-editor ;
multiline-editor "general" f {
{ T{ key-down f f "RET" } insert-newline }
@ -485,33 +482,34 @@ multiline-editor "general" f {
{ T{ key-down f f "ENTER" } insert-newline }
} define-command-map
TUPLE: source-editor ;
TUPLE: 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
TUPLE: field model editor ;
! Fields wrap an editor and edit an external model
TUPLE: field < wrapper field-model editor ;
: field-theme ( gadget -- gadget )
gray <solid> >>boundary ; inline
: <field-border> ( gadget -- border )
2 <border>
{ 1 0 } over set-border-fill
dup field-theme ;
{ 1 0 } >>fill
field-theme ;
: <field> ( model -- gadget )
<editor> dup <field-border>
{ set-field-model set-field-editor set-gadget-delegate }
field construct ;
<editor> dup <field-border> field new-wrapper
swap >>editor
swap >>field-model ;
M: field graft*
dup field-model model-value
over field-editor set-editor-string
dup field-editor gadget-model add-connection ;
[ [ field-model>> model-value ] [ editor>> ] bi set-editor-string ]
[ dup editor>> model>> add-connection ]
bi ;
M: field ungraft*
dup field-editor gadget-model remove-connection ;
dup editor>> model>> remove-connection ;
M: field model-changed
nip
dup field-editor editor-string
swap field-model set-model ;
nip [ editor>> editor-string ] [ field-model>> ] bi 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
! gadgets gets left-over space.
TUPLE: frame ;
TUPLE: frame < grid ;
: <frame-grid> ( -- grid ) 9 [ <gadget> ] replicate 3 group ;
@ -21,9 +21,11 @@ TUPLE: frame ;
: @bottom-left 0 2 ;
: @bottom-right 2 2 ;
: new-frame ( class -- frame )
<frame-grid> swap new-grid ; inline
: <frame> ( -- frame )
frame new
<frame-grid> <grid> over set-gadget-delegate ;
frame new-frame ;
: (fill-center) ( vec n -- )
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 } } }
{ $description "Creates a new gadget." } ;
{ <gadget> set-gadget-delegate } related-words
HELP: relative-loc
{ $values { "fromgadget" gadget } { "togadget" gadget } { "loc" "a pair of integers" } }
{ $description
@ -99,11 +97,6 @@ HELP: each-child
{ $values { "gadget" gadget } { "quot" "a quotation with stack effect " { $snippet "( child -- )" } } }
{ $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?
{ $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 } "." } ;
@ -261,33 +254,7 @@ HELP: g->
{ $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 } "." } ;
HELP: construct-control
{ $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
{ control-value set-control-value gadget-model } related-words
HELP: control-value
{ $values { "control" gadget } { "value" object } }
@ -298,10 +265,8 @@ HELP: set-control-value
{ $description "Sets the value of the control's model." } ;
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
"To implement a new control, simply use this word in your constructor:"
{ $subsection construct-control }
"Some utility words useful in control implementations:"
{ $subsection gadget-model }
{ $subsection control-value }

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

@ -36,13 +36,6 @@ prettyprint io.streams.string ;
intersects?
] unit-test
TUPLE: fooey ;
C: <fooey> fooey
[ ] [ <gadget> <fooey> set-gadget-delegate ] unit-test
[ ] [ f <fooey> set-gadget-delegate ] unit-test
[ { 300 300 } ]
[
! c contains b contains a
@ -113,7 +106,7 @@ C: <fooey> fooey
TUPLE: mock-gadget graft-called ungraft-called ;
: <mock-gadget>
: <mock-gadget> ( -- gadget )
0 0 mock-gadget boa <gadget> over set-delegate ;
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 ;
TUPLE: rect loc dim ;
TUPLE: rect { loc initial: { 0 0 } } { dim initial: { 0 0 } } ;
: <zero-rect> ( -- rect ) rect new ;
C: <rect> rect
@ -44,12 +46,14 @@ M: array rect-dim drop { 0 0 } ;
: rect-union ( rect1 rect2 -- newrect )
(rect-union) <extent-rect> ;
TUPLE: gadget < identity-tuple
TUPLE: gadget < rect
pref-dim parent children orientation focus
visible? root? clipped? layout-state graft-state graft-node
interior boundary
model ;
M: gadget equal? 2drop f ;
M: gadget hashcode* drop gadget hashcode* ;
M: gadget model-changed 2drop ;
@ -58,15 +62,14 @@ M: gadget model-changed 2drop ;
: 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 )
<zero-rect> { 0 1 } t { f f } {
set-delegate
set-gadget-orientation
set-gadget-visible?
set-gadget-graft-state
} gadget construct ;
gadget new-gadget ;
: construct-gadget ( class -- tuple )
>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
] when set-delegate ;
: construct-control ( model gadget class -- control )
>r tuck set-gadget-model
{ set-gadget-delegate } r> construct ; inline
! Selection protocol
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.
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
TUPLE: grid children gap fill? ;
TUPLE: grid < gadget
grid
{ gap initial: { 0 0 } }
{ fill? initial: t } ;
: set-grid-children* ( children grid -- )
[ set-grid-children ] 2keep >r concat r> add-gadgets ;
: new-grid ( children class -- grid )
new-gadget
[ (>>grid) ] [ >r concat r> add-gadgets ] [ nip ] 2tri ;
inline
: <grid> ( children -- grid )
grid construct-gadget
[ set-grid-children* ] keep
{ 0 0 } over set-grid-gap
t over set-grid-fill? ;
grid new-grid ;
: 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 -- )
>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 -- )
>r >r >r <gadget> r> r> r> grid-add ;
: pref-dim-grid ( grid -- dims )
grid-children [ [ pref-dim ] map ] map ;
grid>> [ [ pref-dim ] map ] map ;
: (compute-grid) ( grid -- seq ) [ max-dim ] map ;
@ -49,7 +51,7 @@ M: grid pref-dim*
gap-sum >r gap-sum r> (pair-up) ;
: do-grid ( dims grid quot -- )
-rot grid-children
-rot grid>>
[ [ pick call ] 2each ] 2each
drop ; inline
@ -65,7 +67,7 @@ M: grid pref-dim*
pick grid-fill? [
pair-up swap [ set-layout-dim ] do-grid
] [
2drop grid-children [ [ prefer ] each ] each
2drop grid>> [ [ prefer ] each ] each
] if ;
: grid-layout ( grid horiz vert -- )
@ -77,12 +79,12 @@ M: grid children-on ( rect gadget -- seq )
dup gadget-children empty? [
2drop f
] [
{ 0 1 } swap grid-children
{ 0 1 } swap grid>>
[ 0 <column> fast-children-on ] keep
<slice> concat
] if ;
M: grid gadget-text*
grid-children
grid>>
[ [ gadget-text ] map ] map format-table
[ 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.
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
! Incremental layout allows adding lines to panes to be O(1).
@ -14,16 +15,16 @@ IN: ui.gadgets.incremental
! New gadgets are added at
! incremental-cursor gadget-orientation v*
TUPLE: incremental cursor ;
TUPLE: incremental < pack cursor ;
: <incremental> ( pack -- incremental )
dup pref-dim
{ set-gadget-delegate set-incremental-cursor }
incremental construct ;
: <incremental> ( -- incremental )
incremental new-gadget
{ 0 1 } >>orientation
{ 0 0 } >>cursor ;
M: incremental pref-dim*
dup gadget-layout-state [
dup delegate pref-dim over set-incremental-cursor
dup call-next-method over set-incremental-cursor
] when 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 ;
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.
USING: accessors arrays hashtables io kernel math namespaces
opengl sequences strings splitting
@ -7,7 +7,7 @@ models ;
IN: ui.gadgets.labels
! A label gadget draws a string.
TUPLE: label text font color ;
TUPLE: label < gadget text font color ;
: label-string ( label -- string )
text>> dup string? [ "\n" join ] unless ; inline
@ -23,10 +23,13 @@ TUPLE: label text font color ;
sans-serif-font >>font
black >>color ; inline
: <label> ( string -- label )
label construct-gadget
: new-label ( string class -- label )
new-gadget
[ set-label-string ] keep
label-theme ;
label-theme ; inline
: <label> ( string -- label )
label new-label ;
M: label pref-dim*
[ font>> open-font ] [ text>> ] bi text-dim ;
@ -37,13 +40,14 @@ M: label draw-gadget*
M: label gadget-text* label-string % ;
TUPLE: label-control ;
TUPLE: label-control < label ;
M: label-control model-changed
swap model-value over set-label-string relayout ;
: <label-control> ( model -- gadget )
"" <label> label-control construct-control ;
"" label-control new-label
swap >>model ;
: text-theme ( gadget -- gadget )
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.
USING: accessors ui.commands ui.gestures ui.render ui.gadgets
ui.gadgets.labels ui.gadgets.scrollers
@ -7,17 +7,20 @@ ui.gadgets.presentations ui.gadgets.viewports ui.gadgets.packs
math.vectors classes.tuple ;
IN: ui.gadgets.lists
TUPLE: list index presenter color hook ;
TUPLE: list < pack index presenter color hook ;
: list-theme ( list -- )
{ 0.8 0.8 1.0 1.0 } swap set-list-color ;
: list-theme ( list -- list )
{ 0.8 0.8 1.0 1.0 } >>color ; inline
: <list> ( hook presenter model -- gadget )
<filled-pile> list construct-control
[ set-list-presenter ] keep
[ set-list-hook ] keep
0 over set-list-index
dup list-theme ;
list new-gadget
{ 0 1 } >>orientation
1 >>fill
0 >>index
swap >>model
swap >>presenter
swap >>hook
list-theme ;
: calc-bounded-index ( n list -- m )
control-value length 1- min 0 max ;
@ -30,9 +33,9 @@ TUPLE: list index presenter color hook ;
hook>> [ [ [ list? ] is? ] find-parent ] prepend ;
: <list-presentation> ( hook elt presenter -- gadget )
keep <presentation>
swap >>hook
text-theme ; inline
keep >r >label text-theme r>
<presentation>
swap >>hook ; inline
: <list-items> ( list -- seq )
[ 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 )
>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 construct-gadget
menu-glass new-gadget
>r over menu-loc over set-rect-loc r>
[ 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.
USING: sequences ui.gadgets kernel math math.functions
math.vectors namespaces math.order ;
math.vectors namespaces math.order accessors ;
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 )
[ 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 ;
: <pack> ( orientation -- pack )
0 0 { 0 0 } <gadget> {
set-gadget-orientation
set-pack-align
set-pack-fill
set-pack-gap
set-delegate
} pack construct ;
pack new-gadget
swap >>orientation ;
: <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 ;
IN: ui.gadgets.panes
TUPLE: pane output current prototype scrolls?
TUPLE: pane < pack
output current prototype scrolls?
selection-color caret mark selecting? ;
: clear-selection ( pane -- )
@ -47,16 +48,19 @@ M: pane gadget-selection
[ pane-current clear-gadget ]
tri ;
: pane-theme ( pane -- )
selection-color >>selection-color drop ;
: pane-theme ( pane -- pane )
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 new
<pile> over set-delegate
<shelf> >>prototype
<pile> <incremental> over add-output
dup prepare-line
dup pane-theme ;
pane new-pane ;
GENERIC: draw-selection ( loc obj -- )
@ -142,14 +146,15 @@ M: style-stream write-gadget
: <scrolling-pane> ( -- pane )
<pane> t over set-pane-scrolls? ;
TUPLE: pane-control quot ;
TUPLE: pane-control < pane quot ;
M: pane-control model-changed
swap model-value swap dup pane-control-quot with-pane ;
: <pane-control> ( model quot -- pane )
>r <pane> pane-control construct-control r>
over set-pane-control-quot ;
pane-control new-pane
swap >>quot
swap >>model ;
: do-pane-stream ( pane-stream quot -- )
>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 ;
! A gadget that arranges its children in a word-wrap style.
TUPLE: paragraph margin ;
TUPLE: paragraph < gadget margin ;
: <paragraph> ( margin -- gadget )
paragraph construct-gadget
paragraph new-gadget
{ 1 0 } over set-gadget-orientation
[ 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.
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.worlds hashtables io kernel prettyprint sequences
strings io.styles words help math models namespaces quotations
ui.commands ui.operations ui.gestures ;
IN: ui.gadgets.presentations
TUPLE: presentation object hook ;
TUPLE: presentation < button object hook ;
: invoke-presentation ( presentation command -- )
over dup presentation-hook call
@ -25,15 +25,14 @@ TUPLE: presentation object hook ;
dup presentation-object over show-summary button-update ;
: <presentation> ( label object -- button )
presentation new
[ drop ] over set-presentation-hook
[ set-presentation-object ] keep
swap [ invoke-primary ] <roll-button>
over set-gadget-delegate ;
swap [ invoke-primary ] presentation new-button
swap >>object
[ drop ] >>hook
roll-button-theme ;
M: presentation ungraft*
dup hand-gadget get-global child? [ dup hide-status ] when
delegate ungraft* ;
call-next-method ;
: <operations-menu> ( presentation -- menu )
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 ;
IN: ui.gadgets.scrollers
TUPLE: scroller viewport x y follows ;
TUPLE: scroller < frame viewport x y follows ;
: find-scroller ( gadget -- scroller/f )
[ [ scroller? ] is? ] find-parent ;
@ -40,14 +40,21 @@ scroller H{
: y-model ( -- model ) g gadget-model model-dependencies second ;
: <scroller> ( gadget -- scroller )
<scroller-model> <frame> scroller construct-control [
: new-scroller ( gadget class -- scroller )
new-frame
t >>root?
<scroller-model> >>model
faint-boundary
[
[
x-model <x-slider> g-> set-scroller-x @bottom frame,
y-model <y-slider> g-> set-scroller-y @right frame,
viewport,
] with-gadget
] keep t >>root? faint-boundary ;
] keep ;
: <scroller> ( gadget -- scroller )
scroller new-scroller ;
: scroll ( value scroller -- )
[
@ -123,7 +130,7 @@ scroller H{
} cond ;
M: scroller layout*
dup delegate layout*
dup call-next-method
dup scroller-follows
[ update-scroller ] 2keep
swap set-scroller-follows ;
@ -134,12 +141,10 @@ M: scroller focusable-child*
M: scroller model-changed
nip f swap set-scroller-follows ;
TUPLE: limited-scroller dim ;
TUPLE: limited-scroller < scroller fixed-dim ;
: <limited-scroller> ( gadget -- scroller )
<scroller>
limited-scroller new
[ set-gadget-delegate ] keep ;
: <limited-scroller> ( gadget dim -- scroller )
>r limited-scroller new-scroller r> >>fixed-dim ;
M: limited-scroller pref-dim*
dim>> ;
fixed-dim>> ;

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

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

21
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.
USING: namespaces ui.gadgets ui.gestures ui.commands kernel
ui.gadgets.scrollers parser prettyprint ui.gadgets.buttons
sequences arrays ui.gadgets.borders ui.gadgets.tracks
ui.gadgets.editors io math
definitions math.vectors assocs refs ;
USING: accessors namespaces kernel parser prettyprint
sequences arrays io math definitions math.vectors assocs refs
ui.gadgets ui.gestures ui.commands ui.gadgets.scrollers
ui.gadgets.buttons ui.gadgets.borders ui.gadgets.tracks
ui.gadgets.editors ;
IN: ui.gadgets.slots
TUPLE: update-object ;
@ -88,7 +88,7 @@ slot-editor "toolbar" f {
{ T{ key-down f f "ESC" } close }
} define-command-map
TUPLE: editable-slot printer ref ;
TUPLE: editable-slot < track printer ref ;
: <edit-button> ( -- gadget )
"..."
@ -118,8 +118,7 @@ TUPLE: editable-slot printer ref ;
} set-gestures
: <editable-slot> ( gadget ref -- editable-slot )
editable-slot new
{ 1 0 } <track> over set-gadget-delegate
[ drop <gadget> ] over set-editable-slot-printer
[ set-editable-slot-ref ] keep
{ 1 0 } editable-slot new-track
swap >>ref
[ drop <gadget> ] >>printer
[ 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.
USING: accessors models models.delay models.filter
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
: <status-bar> ( model -- gadget )
@ -11,7 +11,9 @@ IN: ui.gadgets.status-bar
t >>root? ;
: open-status-window ( gadget title -- )
>r [
1 track,
f <model> dup <status-bar> f track,
] { 0 1 } make-track r> rot <world> open-world-window ;
f <model> [ <world> ] keep
<status-bar> over f track-add
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.
USING: ui.gadgets ui.gadgets.packs io kernel math namespaces
sequences words math.vectors ;
USING: accessors io kernel math namespaces
sequences words math.vectors ui.gadgets ui.gadgets.packs ;
IN: ui.gadgets.tracks
TUPLE: track sizes ;
TUPLE: track < pack sizes ;
: normalized-sizes ( track -- seq )
track-sizes
[ 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 )
<pack> V{ } clone
{ set-delegate set-track-sizes } track construct
1 over set-pack-fill ;
track new-track ;
: alloted-dim ( track -- dim )
dup gadget-children swap track-sizes { 0 0 }

11
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.
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 ;
: viewport-gap { 3 3 } ; inline
TUPLE: viewport ;
TUPLE: viewport < gadget ;
: find-viewport ( gadget -- viewport )
[ viewport? ] find-parent ;
@ -15,8 +15,9 @@ TUPLE: viewport ;
gadget-child pref-dim viewport-gap 2 v*n v+ ;
: <viewport> ( content model -- viewport )
<gadget> viewport construct-control
t over set-gadget-clipped?
viewport new-gadget
swap >>model
t >>clipped?
[ add-gadget ] keep ;
M: viewport layout*

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

@ -29,15 +29,15 @@ HELP: focus-path
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:"
{ $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." }
{ { $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." }
{ { $link world-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." }
{ { $link world-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." }
{ { $link world-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." }
{ { $link world-loc } " - the on-screen location of the native window containing the world. The co-ordinate system here is backend-specific." }
{ { $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." }
{ { $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." }
{ { $snippet "title" } " - a string to be displayed in the title bar of the native window containing the world." }
{ { $snippet "status" } " - a " { $link model } " holding a string to be displayed in the world's status bar." }
{ { $snippet "focus" } " - the current owner of the keyboard focus in the world." }
{ { $snippet "focused?" } " - a boolean indicating if the native window containing the world has keyboard focus." }
{ { $snippet "fonts" } " - a hashtable mapping font instances to vectors of " { $link sprite } " instances." }
{ { $snippet "handle" } " - a backend-specific native handle representing the native window containing the world, or " { $link f } " if the world is not grafted." }
{ { $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
: <test-world> ( gadget -- world )
[ gadget, ] make-pile "Hi" f <world> ;
"Hi" f <world> ;
[ ] [
"g1" get <test-world> "w" set
@ -46,15 +46,15 @@ namespaces models kernel ;
[ t ] [ <gadget> dup <test-world> focusable-child eq? ] unit-test
TUPLE: focusing ;
TUPLE: focusing < gadget ;
: <focusing>
focusing construct-gadget ;
focusing new-gadget ;
TUPLE: focus-test ;
TUPLE: focus-test < gadget ;
: <focus-test>
focus-test construct-gadget
focus-test new-gadget
<focusing> over add-gadget ;
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.
! 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
ui.gadgets ui.gestures ui.render ui.backend summary
ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks
debugger ;
IN: ui.gadgets.worlds
TUPLE: world < identity-tuple
TUPLE: world < track
active? focused?
glass
title status
fonts handle
loc ;
window-loc ;
: find-world ( gadget -- world ) [ world? ] find-parent ;
@ -20,9 +20,6 @@ M: f world-status ;
: show-status ( string/f gadget -- )
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 ;
: (request-focus) ( child world ? -- )
@ -36,21 +33,18 @@ M: world request-focus-on ( child gadget -- )
[ 2drop ] [ dup world-focused? (request-focus) ] if ;
: <world> ( gadget title status -- world )
t H{ } clone { 0 0 } {
set-gadget-delegate
set-world-title
set-world-status
set-world-active?
set-world-fonts
set-world-loc
} world construct
t over set-gadget-root?
{ 0 1 } world new-track
t >>root?
t >>active?
H{ } clone >>fonts
{ 0 0 } >>window-loc
swap >>status
swap >>title
[ 1 track-add ] keep
dup request-focus ;
M: world hashcode* drop world hashcode* ;
M: world layout*
dup delegate layout*
dup call-next-method
dup world-glass [
>r dup rect-dim r> set-layout-dim
] 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 -- ? )
: 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 ;
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-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
"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 } "." } ;
"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 } "." } ;
HELP: clip
{ $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
! 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 -- )
<mailbox> >>mailbox
@ -39,18 +40,17 @@ TUPLE: interactor output history flag mailbox thread waiting help ;
editor-caret 1/3 seconds <delay> ;
: <interactor> ( output -- gadget )
<source-editor>
interactor construct-editor
interactor new-editor
V{ } clone >>history
<flag> >>flag
dup <help-model> >>help
swap >>output ;
M: interactor graft*
[ delegate graft* ] [ dup help>> add-connection ] bi ;
[ call-next-method ] [ dup help>> add-connection ] bi ;
M: interactor ungraft*
[ dup help>> remove-connection ] [ delegate ungraft ] bi ;
[ dup help>> remove-connection ] [ call-next-method ] bi ;
: word-at-loc ( loc interactor -- word )
over [
@ -64,7 +64,7 @@ M: interactor model-changed
2dup help>> eq? [
swap model-value over word-at-loc swap show-summary
] [
delegate model-changed
call-next-method
] if ;
: write-input ( string input -- )
@ -180,7 +180,7 @@ M: interactor stream-read-quot
} cond ;
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 ;
interactor "interactor" f {

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

@ -24,7 +24,7 @@ TUPLE: listener-gadget input output stack ;
: listener-input, ( -- )
g <listener-input> g-> set-listener-gadget-input
<limited-scroller> { 0 100 } >>dim
{ 0 100 } <limited-scroller>
"Input" <labelled-gadget> f track, ;
: 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-live-search live-search-list ;
TUPLE: search-field ;
TUPLE: search-field < editor ;
: <search-field> ( -- gadget )
<editor> search-field construct-editor ;
search-field new-editor ;
search-field H{
{ 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.
! 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.inspector ui.tools.listener ui.tools.profiler
ui.tools.operations inspector io kernel math models namespaces
@ -27,7 +27,9 @@ IN: ui.tools
] { } make g gadget-model <book> ;
: <workspace> ( -- workspace )
0 <model> { 0 1 } <track> workspace construct-control [
{ 0 1 } workspace new-track
0 <model> >>model
[
[
<listener-gadget> g set-workspace-listener
<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.
! See http://factorcode.org/license.txt for BSD license.
USING: continuations kernel models namespaces prettyprint ui
ui.commands ui.gadgets ui.gadgets.labelled assocs
USING: accessors continuations kernel models namespaces
prettyprint ui ui.commands ui.gadgets ui.gadgets.labelled assocs
ui.gadgets.tracks ui.gadgets.buttons ui.gadgets.panes
ui.gadgets.status-bar ui.gadgets.scrollers
ui.gestures sequences hashtables inspector ;
ui.gadgets.status-bar ui.gadgets.scrollers ui.gestures sequences
hashtables inspector ;
IN: ui.tools.traceback
: <callstack-display> ( model -- gadget )
@ -19,12 +19,14 @@ IN: ui.tools.traceback
[ [ continuation-retain stack. ] when* ]
t "Retain stack" <labelled-pane> ;
TUPLE: traceback-gadget ;
TUPLE: traceback-gadget < track ;
M: traceback-gadget pref-dim* drop { 550 600 } ;
: <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,
@ -39,14 +41,8 @@ M: traceback-gadget pref-dim* drop { 550 600 } ;
[ [ continuation-name namestack. ] when* ]
<pane-control> ;
TUPLE: variables-gadget ;
: <variables-gadget> ( model -- gadget )
<namestack-display> <scroller>
variables-gadget new
[ set-gadget-delegate ] keep ;
M: variables-gadget pref-dim* drop { 400 400 } ;
<namestack-display> { 400 400 } <limited-scroller> ;
: variables ( traceback -- )
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 ;
IN: ui.tools.workspace
TUPLE: workspace book listener popup ;
TUPLE: workspace < track book listener popup ;
: find-workspace ( gadget -- workspace )
[ workspace? ] find-parent ;
@ -52,7 +52,7 @@ M: gadget tool-scroller drop f ;
: help-window ( topic -- )
[
<pane> [ [ help ] with-pane ] keep
<limited-scroller> { 550 700 } >>dim
{ 550 700 } <limited-scroller>
] keep
article-title open-window ;

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

@ -359,10 +359,8 @@ ARTICLE: "new-gadgets" "Implementing new gadgets"
$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" } "):"
{ $subsection <gadget> }
"You can construct a new tuple which delegates to a bare gadget:"
{ $subsection construct-gadget }
"You can also delegate a tuple to an existing gadget:"
{ $subsection set-gadget-delegate }
"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 new-gadget }
"Further topics:"
{ $subsection "ui-gestures" }
{ $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 ;
: open-window ( gadget title -- )
>r [ 1 track, ] { 0 1 } make-track r>
f <world> open-world-window ;
: 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 -- )
2nip
[ lo-word ] keep hi-word 2array
swap window set-world-loc ;
swap window (>>window-loc) ;
: wm-keydown-codes ( -- key )
H{
@ -420,7 +420,7 @@ M: windows-ui-backend do-events
style 0 ex-style AdjustWindowRectEx win32-error=0/f ;
: 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>
over first over set-RECT-right
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 configure-event
over configured-loc over set-world-loc
over configured-loc over (>>window-loc)
swap configured-dim over set-gadget-dim
! In case dimensions didn't change
relayout-1 ;
@ -170,7 +170,7 @@ M: world client-event
swap close-box? [ ungraft ] [ drop ] if ;
: 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>
2dup x11-handle-window register-window
swap set-world-handle ;