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

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

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

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

@ -11,10 +11,10 @@ IN: color-picker
: <color-slider> ( model -- gadget )
<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

732
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-instruction ( -- parser )
[
"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-instruction ( -- parser )
[
"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-instruction ( -- parser )
[
"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-instruction ( -- parser )
[
"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 ;

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

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

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

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

2
extra/lisp/lisp.factor
View File

@ -99,7 +99,7 @@ PRIVATE>
uncons [ list>seq [ ] like ] [ lookup-macro lambda-rewrite call ] bi* call compile-form call ;
: 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

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

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

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

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

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

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

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

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

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

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

3
extra/models/models.factor
View File

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

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

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

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

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

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

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

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

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

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

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

@ -1,9 +1,9 @@
! Copyright (C) 2006, 2007 Slava Pestov.
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
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 ;

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

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

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

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

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

@ -16,7 +16,7 @@ TUPLE: foo-gadget ;
T{ foo-gadget } <toolbar> "t" set
[ 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> {

72
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
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.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 < border pressed? selected? quot ;
: buttons-down? ( -- ? )
hand-buttons get-global empty? not ;
@ -39,10 +40,11 @@ button H{
{ T{ mouse-enter } [ button-update ] }
} set-gestures
: <button> ( gadget quot -- button )
button new
swap >>quot
[ set-gadget-delegate ] keep ;
: new-button ( label quot class -- button )
[ swap >label ] dip new-border swap >>quot ; inline
: <button> ( label quot -- button )
button new-button ;
TUPLE: button-paint plain rollover pressed selected ;
@ -66,10 +68,11 @@ M: button-paint draw-boundary
button-paint draw-boundary ;
: roll-button-theme ( button -- button )
f black <solid> dup f <button-paint> >>boundary ; inline
f black <solid> dup f <button-paint> >>boundary
{ 0 1/2 } >>align ; inline
: <roll-button> ( label quot -- button )
>r >label r> <button> roll-button-theme ;
<button> roll-button-theme ;
: <bevel-button-paint> ( -- paint )
plain-gradient
@ -80,13 +83,13 @@ M: button-paint draw-boundary
: bevel-button-theme ( gadget -- gadget )
<bevel-button-paint> >>interior
{ 5 5 } >>size
faint-boundary ; inline
: <bevel-button> ( label quot -- button )
>r >label 5 <border> r>
<button> bevel-button-theme ;
TUPLE: repeat-button ;
TUPLE: repeat-button < button ;
repeat-button H{
{ T{ drag } [ button-clicked ] }
@ -95,8 +98,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 ;
repeat-button new-button bevel-button-theme ;
TUPLE: checkmark-paint color ;
@ -128,20 +130,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 +173,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 +191,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 +206,7 @@ M: radio-control model-changed
dup radio-buttons-theme ;
: <toggle-button> ( value model label -- gadget )
[ <bevel-button> ] <radio-control> ;
<radio-control> bevel-button-theme ;
: <toggle-buttons> ( model assoc -- gadget )
[ [ <toggle-button> ] <radio-controls> ] make-shelf ;
@ -224,7 +222,7 @@ M: radio-control model-changed
: <toolbar> ( target -- toolbar )
[
"toolbar" over class command-map swap
"toolbar" over class command-map commands>> swap
[ -rot <command-button> gadget, ] curry assoc-each
] 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 -- )

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

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

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

@ -1,43 +1,38 @@
! Copyright (C) 2006, 2007 Slava Pestov
! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
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
self
TUPLE: editor < gadget
font color caret-color selection-color
caret mark
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 ; 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
@ -212,19 +207,19 @@ M: editor pref-dim*
dup editor-font* swap control-value text-dim ;
: contents-changed ( model editor -- )
editor-self swap
over editor-caret [ over validate-loc ] (change-model)
over editor-mark [ over validate-loc ] (change-model)
swap
over caret>> [ over validate-loc ] (change-model)
over mark>> [ over validate-loc ] (change-model)
drop relayout ;
: caret/mark-changed ( model editor -- )
nip editor-self dup relayout-1 scroll>caret ;
nip [ relayout-1 ] [ scroll>caret ] bi ;
M: editor model-changed
{
{ [ 2dup gadget-model eq? ] [ contents-changed ] }
{ [ 2dup editor-caret eq? ] [ caret/mark-changed ] }
{ [ 2dup editor-mark eq? ] [ caret/mark-changed ] }
{ [ 2dup model>> eq? ] [ contents-changed ] }
{ [ 2dup caret>> eq? ] [ caret/mark-changed ] }
{ [ 2dup mark>> eq? ] [ caret/mark-changed ] }
} cond ;
M: editor gadget-selection?
@ -474,10 +469,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 +480,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 ;

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

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

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

@ -6,7 +6,7 @@ IN: ui.gadgets.frames
! A frame arranges gadgets in a 3x3 grid, where the center
! 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,8 +41,5 @@ M: frame layout*
: make-frame ( quot -- frame )
<frame> make-gadget ; inline
: build-frame ( tuple quot -- tuple )
<frame> build-gadget ; inline
: frame, ( gadget i j -- )
\ make-gadget get -rot grid-add ;

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

@ -65,8 +65,6 @@ HELP: <gadget>
{ $values { "gadget" "a new " { $link gadget } } }
{ $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 } "." } ;
@ -239,55 +232,25 @@ HELP: focusable-child
HELP: gadget,
{ $values { "gadget" gadget } }
{ $description "Adds a new child to the gadget being constructed. This word can only be used from a quotation passed to " { $link make-gadget } " or " { $link build-gadget } "." } ;
{ $description "Adds a new child to the gadget being constructed. This word can only be used from a quotation passed to " { $link make-gadget } "." } ;
HELP: make-gadget
{ $values { "quot" quotation } { "gadget" gadget } }
{ $description "Calls the quotation in a new scope with the gadget stored in the " { $link make-gadget } " variable." } ;
HELP: build-gadget
{ $values { "tuple" tuple } { "quot" quotation } { "gadget" gadget } }
{ $description "Delegates the tuple to the gadget, and calls the quotation in a new scope with the tuple stored in the " { $link make-gadget } " and " { $link gadget } " variables." } ;
HELP: with-gadget
{ $values { "gadget" gadget } { "quot" quotation } }
{ $description "Calls the quotation in a new scope with the " { $link gadget } " and " { $link make-gadget } " variables set to " { $snippet "gadget" } ". The quotation can call " { $link g } " and " { $link g-> } " to access the gadget." } ;
HELP: g
{ $values { "gadget" gadget } }
{ $description "Outputs the gadget being built. Can only be used inside a quotation passed to " { $link build-gadget } "." } ;
{ $description "Outputs the gadget being built. Can only be used inside a quotation passed to " { $link with-gadget } "." } ;
HELP: g->
{ $values { "x" object } { "gadget" gadget } }
{ $description "Duplicates the top of the stack and outputs the gadget being built. Can only be used inside a quotation passed to " { $link build-gadget } "." } ;
{ $description "Duplicates the top of the stack and outputs the gadget being built. Can only be used inside a quotation passed to " { $link with-gadget } "." } ;
HELP: construct-control
{ $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 +261,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*

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

@ -9,7 +9,9 @@ SYMBOL: ui-notify-flag
: notify-ui-thread ( -- ) ui-notify-flag get-global raise-flag ;
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,18 +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 ;
: construct-gadget ( class -- tuple )
>r <gadget> r> construct-delegate ; inline
gadget new-gadget ;
: activate-control ( gadget -- )
dup gadget-model dup [
@ -137,15 +137,6 @@ M: gadget children-on nip gadget-children ;
: each-child ( gadget quot -- )
>r gadget-children r> each ; inline
: set-gadget-delegate ( gadget tuple -- )
over [
dup pick [ set-gadget-parent ] with each-child
] when set-delegate ;
: construct-control ( model gadget class -- control )
>r tuck set-gadget-model
{ set-gadget-delegate } r> construct ; inline
! Selection protocol
GENERIC: gadget-selection? ( gadget -- ? )
@ -414,5 +405,11 @@ M: f request-focus-on 2drop ;
swap dup \ make-gadget set gadget set call
] with-scope ; inline
: build-gadget ( tuple quot gadget -- tuple )
pick set-gadget-delegate over >r with-gadget r> ; inline
! Deprecated
: set-gadget-delegate ( gadget tuple -- )
over [
dup pick [ set-gadget-parent ] with each-child
] when set-delegate ;
: construct-gadget ( class -- tuple )
>r <gadget> { set-delegate } r> construct ; inline

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

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

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

@ -1,31 +1,33 @@
! Copyright (C) 2006 Slava Pestov.
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
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-docs.factor
View File

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

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

@ -1,6 +1,7 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
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

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

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

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

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

@ -1,10 +1,13 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
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> ;
@ -71,7 +69,3 @@ M: pack children-on ( rect gadget -- seq )
: make-shelf ( quot -- pack )
<shelf> make-gadget ; inline
: build-pack ( quot quot orientation -- pack )
<pack> build-gadget ; inline

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

@ -1,4 +1,4 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays ui.gadgets ui.gadgets.borders ui.gadgets.buttons
ui.gadgets.labels ui.gadgets.scrollers
@ -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
@ -195,13 +200,15 @@ M: pane-stream make-span-stream
: apply-presentation-style ( style gadget -- style gadget )
presented [ <presentation> ] apply-style ;
: <styled-label> ( style text -- gadget )
<label>
: style-label ( style gadget -- gadget )
apply-foreground-style
apply-background-style
apply-font-style
apply-presentation-style
nip ;
nip ; inline
: <styled-label> ( style text -- gadget )
<label> style-label ;
! Paragraph styles
@ -235,28 +242,27 @@ M: pane-stream make-span-stream
apply-printer-style
nip ;
TUPLE: nested-pane-stream style parent ;
TUPLE: nested-pane-stream < pane-stream style parent ;
: <nested-pane-stream> ( style parent -- stream )
>r <pane> apply-wrap-style <pane-stream> r> {
set-nested-pane-stream-style
set-delegate
set-nested-pane-stream-parent
} nested-pane-stream construct ;
: new-nested-pane-stream ( style parent class -- stream )
new
swap >>parent
swap <pane> apply-wrap-style [ >>style ] [ >>pane ] bi* ;
inline
: unnest-pane-stream ( stream -- child parent )
dup ?nl
dup nested-pane-stream-style
over pane-stream-pane smash-pane style-pane
swap nested-pane-stream-parent ;
dup style>>
over pane>> smash-pane style-pane
swap parent>> ;
TUPLE: pane-block-stream ;
TUPLE: pane-block-stream < nested-pane-stream ;
M: pane-block-stream dispose
unnest-pane-stream write-gadget ;
M: pane-stream make-block-stream
<nested-pane-stream> pane-block-stream construct-delegate ;
pane-block-stream new-nested-pane-stream ;
! Tables
: apply-table-gap-style ( style grid -- style grid )
@ -273,12 +279,12 @@ M: pane-stream make-block-stream
apply-table-border-style
nip ;
TUPLE: pane-cell-stream ;
TUPLE: pane-cell-stream < nested-pane-stream ;
M: pane-cell-stream dispose ?nl ;
M: pane-stream make-cell-stream
<nested-pane-stream> pane-cell-stream construct-delegate ;
pane-cell-stream new-nested-pane-stream ;
M: pane-stream stream-write-table
>r
@ -298,7 +304,7 @@ M: paragraph dispose drop ;
M: pack stream-write gadget-write ;
: gadget-bl ( style stream -- )
>r " " <styled-label> <word-break-gadget> r> add-gadget ;
>r " " <word-break-gadget> style-label r> add-gadget ;
M: paragraph stream-write
swap " " split

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

@ -5,18 +5,18 @@ namespaces sequences math.order ;
IN: ui.gadgets.paragraphs
! A word break gadget
TUPLE: word-break-gadget ;
TUPLE: word-break-gadget < label ;
: <word-break-gadget> ( gadget -- gadget )
{ set-delegate } word-break-gadget construct ;
: <word-break-gadget> ( text -- gadget )
word-break-gadget new-label ;
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 ;

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

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

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

@ -1,13 +1,14 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays 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 ;
USING: arrays accessors definitions hashtables io kernel
prettyprint sequences strings io.styles words help math models
namespaces quotations
ui.gadgets ui.gadgets.borders ui.gadgets.buttons
ui.gadgets.labels ui.gadgets.menus ui.gadgets.worlds
ui.gadgets.status-bar 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 +26,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>> ;

23
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,9 +71,9 @@ thumb H{
faint-boundary ; inline
: <thumb> ( vector -- thumb )
thumb construct-gadget
swap >>orientation
t >>root?
thumb new-gadget
swap >>orientation
t >>root?
thumb-theme ;
: slide-by ( amount slider -- )
@ -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 ;

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

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

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

@ -1,10 +1,10 @@
! Copyright (C) 2007 Slava Pestov.
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
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 ;
@ -13,7 +13,7 @@ TUPLE: update-slot ;
TUPLE: edit-slot ;
TUPLE: slot-editor ref text ;
TUPLE: slot-editor < track ref text ;
: revert ( slot-editor -- )
dup slot-editor-ref get-ref unparse-use
@ -69,16 +69,20 @@ M: value-ref finish-editing
} define-command
: <slot-editor> ( ref -- gadget )
slot-editor new
[ set-slot-editor-ref ] keep
{ 0 1 } slot-editor new-track
swap >>ref
[
toolbar,
<source-editor> g-> set-slot-editor-text
<scroller> 1 track,
] { 0 1 } build-track
[
toolbar,
<source-editor> g-> set-slot-editor-text
<scroller> 1 track,
] with-gadget
] keep
dup revert ;
M: slot-editor pref-dim* delegate pref-dim* { 600 200 } vmin ;
M: slot-editor pref-dim* call-next-method { 600 200 } vmin ;
M: slot-editor focusable-child* text>> ;
slot-editor "toolbar" f {
{ T{ key-down f { C+ } "RET" } commit }
@ -88,7 +92,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 )
"..."
@ -100,17 +104,16 @@ TUPLE: editable-slot printer ref ;
[ 1 track, <edit-button> f track, ] with-gadget ;
: update-slot ( editable-slot -- )
[
dup editable-slot-ref get-ref
swap editable-slot-printer call
] keep
[ display-slot ] keep
scroll>gadget ;
[ [ ref>> get-ref ] [ printer>> ] bi call ] keep
display-slot ;
: edit-slot ( editable-slot -- )
dup clear-track dup [
dup editable-slot-ref <slot-editor> 1 track,
] with-gadget scroll>gadget ;
[ clear-track ]
[
dup ref>> <slot-editor>
[ swap 1 track-add ]
[ [ scroll>gadget ] [ request-focus ] bi* ] 2bi
] bi ;
\ editable-slot H{
{ T{ update-slot } [ update-slot ] }
@ -118,8 +121,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
[ display-slot ] keep ;
{ 1 0 } editable-slot new-track
swap >>ref
[ drop <gadget> ] >>printer
[ display-slot ] keep ;

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

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

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 ;

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

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

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

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

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

@ -1,19 +1,23 @@
! Copyright (C) 2006, 2007 Slava Pestov.
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
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 class -- 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 }
@ -51,9 +55,6 @@ M: track pref-dim*
: make-track ( quot orientation -- track )
<track> make-gadget ; inline
: build-track ( tuple quot orientation -- tuple )
<track> build-gadget ; inline
: track-remove ( gadget track -- )
over [
[ gadget-children index ] 2keep

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

@ -1,12 +1,12 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
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,9 +15,10 @@ 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?
[ add-gadget ] keep ;
viewport new-gadget
swap >>model
t >>clipped?
[ add-gadget ] keep ;
M: viewport layout*
dup rect-dim viewport-gap 2 v*n v-

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

@ -29,15 +29,15 @@ HELP: focus-path
HELP: world
{ $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 ;

38
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 ;
@ -71,11 +65,9 @@ M: world children-on nip gadget-children ;
over world-handle
rot rect-dim [ 0 > ] all? and and ;
TUPLE: world-error world ;
TUPLE: world-error error world ;
: <world-error> ( error world -- error )
{ set-delegate set-world-error-world }
world-error construct ;
C: <world-error> world-error
SYMBOL: ui-error-hook

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

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

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

@ -11,7 +11,7 @@ IN: ui.gestures
GENERIC: handle-gesture* ( gadget gesture delegate -- ? )
: 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 ;

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

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

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

@ -17,11 +17,9 @@ HELP: gadget
{ { $link gadget-boundary } " - an object whose class implements the " { $link draw-boundary } " generic word." }
{ { $link gadget-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." } ;

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

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

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

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

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

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

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

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

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

@ -4,7 +4,7 @@ USING: arrays assocs combinators continuations documents
hashtables io io.styles kernel math math.order math.vectors
models models.delay namespaces parser lexer prettyprint
quotations sequences strings threads listener classes.tuple
ui.commands ui.gadgets ui.gadgets.editors
ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.status-bar
ui.gadgets.presentations ui.gadgets.worlds ui.gestures
definitions calendar concurrency.flags concurrency.mailboxes
ui.tools.workspace accessors sets destructors ;
@ -12,7 +12,8 @@ IN: ui.tools.interactor
! If waiting is t, we're waiting for user input, and invoking
! 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-tests.factor
View File

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

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

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

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

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

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

@ -11,7 +11,7 @@ vocabs words vocabs.loader tools.vocabs unicode.case calendar ui
;
IN: ui.tools.search
TUPLE: live-search field list ;
TUPLE: live-search < track field list ;
: search-value ( live-search -- value )
live-search-list list-value ;
@ -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 ] }
@ -60,12 +60,14 @@ search-field H{
swap <list> ;
: <live-search> ( string seq limited? presenter -- gadget )
live-search new
{ 0 1 } live-search new-track
[
<search-field> g-> set-live-search-field f track,
<search-list> g-> set-live-search-list
<scroller> 1 track,
] { 0 1 } build-track
[
<search-field> g-> set-live-search-field f track,
<search-list> g-> set-live-search-list
<scroller> 1 track,
] with-gadget
] keep
[ live-search-field set-editor-string ] keep
[ live-search-field end-of-document ] keep ;

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

@ -1,6 +1,6 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! 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
@ -14,7 +14,7 @@ IN: ui.tools
: <workspace-tabs> ( -- tabs )
g gadget-model
"tool-switching" workspace command-map
"tool-switching" workspace command-map commands>>
[ command-string ] { } assoc>map <enum> >alist
<toggle-buttons> ;
@ -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>

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

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

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

@ -8,7 +8,7 @@ ui.gadgets.worlds ui.gadgets.presentations ui.gadgets.status-bar
ui.commands ui.gestures assocs arrays namespaces accessors ;
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 ;

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

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

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

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