! See http://factor.sf.net/license.txt for BSD license.
IN: namespaces
USING: hashtables kernel kernel-internals lists math sequences
-strings vectors ;
+strings vectors words ;
! Variables in Factor:
!
: literal, ( word -- )
#! Append some code that pushes the word on the stack. Used
#! when building quotations.
- unit , \ car , ;
+ literalize % ;
: unique, ( obj -- )
#! Add the object to the sequence being built with make-seq
: \
#! Parsed as a piece of code that pushes a word on the stack
#! \ foo ==> [ foo ] car
- scan-word dup word? [
- unit swons \ car swons
- ] [
- swons
- ] ifte ; parsing
+ scan-word literalize [ swons ] each ; parsing
! Vocabularies
: PRIMITIVE:
GENERIC: prettyprint* ( indent obj -- indent )
-M: object prettyprint* ( indent obj -- indent )
+: unparse. ( obj -- )
dup unparse swap presented swons unit write-attr ;
-: word-attrs ( word -- style )
- #! Return the style values for the HTML word browser
- [
- presented over cons ,
- dup word-vocabulary [
- "word" over word-name cons ,
- "vocab" swap word-vocabulary cons ,
- ] [
- drop
- ] ifte
- ] make-list ;
-
-: word. ( word -- ) dup word-name swap word-attrs write-attr ;
+M: object prettyprint* ( indent obj -- indent )
+ unparse. ;
M: word prettyprint* ( indent word -- indent )
- dup parsing? [ \ POSTPONE: word. bl ] when word. ;
+ dup parsing? [ \ POSTPONE: unparse. bl ] when unparse. ;
: indent ( indent -- )
#! Print the given number of spaces.
: prettyprint-elements ( indent list -- indent )
[
dup \? [
- \ \ word. bl
- uncons >r car word. bl
+ \ \ unparse. bl
+ uncons >r car unparse. bl
r> cdr prettyprint-elements
] [
uncons >r prettyprint* bl
#! or { }, or << >>. The body of the list is indented,
#! unless the list is empty.
over [
- >r >r word. <prettyprint
+ >r >r unparse. <prettyprint
r> prettyprint-elements
- prettyprint> r> word.
+ prettyprint> r> unparse.
] [
- >r >r word. bl r> drop r> word.
+ >r >r unparse. bl r> drop r> unparse.
] ifte ;
M: list prettyprint* ( indent list -- indent )
] check-recursion ;
M: alien prettyprint* ( alien -- str )
- \ ALIEN: word. bl alien-address unparse write ;
+ \ ALIEN: unparse. bl alien-address unparse write ;
: matrix-rows. ( indent list -- indent )
uncons >r [ one-line on prettyprint* ] with-scope r>
[ over ?prettyprint-newline matrix-rows. ] when* ;
M: matrix prettyprint* ( indent obj -- indent )
- \ M[ word. bl >r 3 + r>
+ \ M[ unparse. bl >r 3 + r>
row-list matrix-rows.
- bl \ ]M word. 3 - ;
+ bl \ ]M unparse. 3 - ;
: prettyprint ( obj -- )
[
0 swap prettyprint* drop terpri
] with-scope ;
-: vocab-link ( vocab -- link )
- "vocabularies'" swap append ;
-
: . ( obj -- )
[
one-line on
: vocab. ( vocab -- ) dup vocab-attrs write-attr ;
: prettyprint-IN: ( word -- )
- \ IN: word. bl word-vocabulary vocab. terpri ;
+ \ IN: unparse. bl word-vocabulary vocab. terpri ;
: prettyprint-prop ( word prop -- )
tuck word-name word-prop [
- bl word.
+ bl unparse.
] [
drop
] ifte ;
] each
] when* ;
-: definer. ( word -- ) dup definer word. bl word. bl ;
+: definer. ( word -- ) dup definer unparse. bl unparse. bl ;
GENERIC: (see) ( word -- )
M: compound (see) ( word -- )
tab-size get dup indent swap
[ documentation. ] keep
- [ word-def prettyprint-elements \ ; word. ] keep
+ [ word-def prettyprint-elements \ ; unparse. ] keep
prettyprint-plist terpri drop ;
: prettyprint-M: ( -- indent )
- \ M: word. bl tab-size get ;
+ \ M: unparse. bl tab-size get ;
-: prettyprint-; \ ; word. terpri ;
+: prettyprint-; \ ; unparse. terpri ;
: method. ( word [[ class method ]] -- )
- uncons >r >r >r prettyprint-M: r> r> word. bl word. bl
+ uncons >r >r >r prettyprint-M: r> r> unparse. bl unparse. bl
dup prettyprint-newline r> prettyprint-elements
prettyprint-; drop ;
over "dispatcher" word-prop prettyprint* bl
] with-scope
drop
- \ ; word. terpri
+ \ ; unparse. terpri
dup methods [ method. ] each-with ;
M: word (see) drop ;
GENERIC: class.
M: union class.
- \ UNION: word. bl
- dup word. bl
+ \ UNION: unparse. bl
+ dup unparse. bl
0 swap "members" word-prop prettyprint-elements drop
prettyprint-; ;
M: complement class.
- \ COMPLEMENT: word. bl
- dup word. bl
- "complement" word-prop word. terpri ;
+ \ COMPLEMENT: unparse. bl
+ dup unparse. bl
+ "complement" word-prop unparse. terpri ;
M: builtin class.
- \ BUILTIN: word. bl
- dup word. bl
+ \ BUILTIN: unparse. bl
+ dup unparse. bl
dup "builtin-type" word-prop unparse write bl
0 swap "slots" word-prop prettyprint-elements drop
prettyprint-; ;
M: predicate class.
- \ PREDICATE: word. bl
- dup "superclass" word-prop word. bl
- dup word. bl
+ \ PREDICATE: unparse. bl
+ dup "superclass" word-prop unparse. bl
+ dup unparse. bl
tab-size get dup prettyprint-newline swap
"definition" word-prop prettyprint-elements drop
prettyprint-; ;
M: tuple-class class.
- \ TUPLE: word. bl
- dup word. bl
+ \ TUPLE: unparse. bl
+ dup unparse. bl
"slot-names" word-prop [ write bl ] each
prettyprint-; ;
: type-check-error. ( list -- )
"Type check error" print
uncons car dup "Object: " write .
- "Object type: " write class word. terpri
- "Expected type: " write builtin-type word. terpri ;
+ "Object type: " write class unparse. terpri
+ "Expected type: " write builtin-type unparse. terpri ;
: float-format-error. ( list -- )
"Invalid floating point literal format: " write . ;
: :get ( var -- value ) "error-namestack" get (get) ;
: debug-help ( -- )
- [ :s :r :n :c ] [ word. bl ] each
+ [ :s :r :n :c ] [ unparse. bl ] each
"show stacks at time of error." print
- \ :get word.
+ \ :get unparse.
" ( var -- value ) inspects the error namestack." print ;
: flush-error-handler ( error -- )
seq-transpose
[ " | " join ] map ;
-: a/an ( noun -- str )
- first "aeiouAEIOU" contains? "an " "a " ? ;
-
-: a/an. ( noun -- )
- dup a/an write write ;
-
: interned? ( word -- ? )
dup word-name swap word-vocabulary vocab hash ;
: class-banner ( word -- )
dup metaclass dup [
"This is a class whose behavior is specifed by the " write
- unparse write " metaclass," print
+ unparse. " metaclass," print
"currently having " write
"predicate" word-prop instances length unparse write
" instances." print
: inspect-banner ( obj -- )
dup references length >r
- "You are looking at " write dup class unparse a/an.
- " object with the following printed representation:" print
- " " write dup unparse print
+ "You are looking at an instance of the " write dup class unparse.
+ " class:" print
+ " " write dup unparse. terpri
"The object has been placed in the inspecting variable." print
"It is located at address " write dup address >hex write
" and takes up " write dup size unparse write
set-callstack call ;
: walk-banner ( -- )
- [ &s &r &n &c ] [ word. bl ] each
+ [ &s &r &n &c ] [ unparse. bl ] each
"show stepper stacks." print
- \ &get word.
+ \ &get unparse.
" ( var -- value ) inspects the stepper namestack." print
- \ step word. " -- single step over" print
- \ into word. " -- single step into" print
- \ continue word. " -- continue execution" print
- \ bye word. " -- exit single-stepper" print
+ \ step unparse. " -- single step over" print
+ \ into unparse. " -- single step into" print
+ \ continue unparse. " -- continue execution" print
+ \ bye unparse. " -- exit single-stepper" print
report ;
: walk-listener walk-banner "walk " listener-prompt set listener ;
[ set-gadget-parent ] 2keep
[ set-hand-gadget ] keep ;
+: hand world get world-hand ;
+
: button/ ( n hand -- )
dup hand-gadget over set-hand-clicked
dup screen-loc over set-hand-click-loc
SYMBOL: stack-display
-: <stack-display>
- ;
-
: init-world
global [
<world> world set
"/library/ui/fonts.factor"
"/library/ui/text.factor"
"/library/ui/gestures.factor"
- "/library/ui/hand.factor"
"/library/ui/layouts.factor"
"/library/ui/borders.factor"
"/library/ui/frames.factor"
"/library/ui/world.factor"
+ "/library/ui/hand.factor"
"/library/ui/labels.factor"
"/library/ui/buttons.factor"
"/library/ui/line-editor.factor"
"/library/ui/editors.factor"
"/library/ui/menus.factor"
"/library/ui/splitters.factor"
- "/library/ui/presentations.factor"
"/library/ui/incremental.factor"
"/library/ui/panes.factor"
+ "/library/ui/presentations.factor"
"/library/ui/init-world.factor"
"/library/ui/ui.factor"
] [
USING: generic hashtables io kernel line-editor listener lists
math namespaces prettyprint sequences strings styles threads ;
+DEFER: <presentation>
+
! A pane is an area that can display text.
! output: pile
pane-input ;
: pane-write-1 ( style text pane -- )
- [ <presentation> ] keep pane-current add-gadget ;
+ >r <presentation> r> pane-current add-gadget ;
: pane-terpri ( pane -- )
dup pane-current over pane-output add-incremental
: define-command ( class name quot -- )
3list commands get push ;
-: applicable ( object -- )
- commands get >list
- [ car call ] subset-with ;
-
-DEFER: pane-call
-
-: command-menu ( pane -- menu )
- presented get dup applicable [
- 3dup third [
- [ swap literal, % ] make-list , ,
- [ pane-call drop ] %
- ] make-list >r second r> cons
- ] map 2nip ;
-
-: init-commands ( gadget pane -- )
- over presented paint-prop [
- [ drop ] swap
- unit
- [ command-menu <menu> show-menu ] append3
+: applicable ( object -- list )
+ commands get >list [ car call ] subset-with ;
+
+: command-quot ( presented quot -- quot )
+ [ swap literal, % ] make-list
+ [ pane get pane-call drop ] cons ;
+
+: command-menu ( presented -- menu )
+ dup applicable
+ [ [ third command-quot ] keep second swons ] map-with
+ <menu> ;
+
+: init-commands ( gadget -- )
+ dup presented paint-prop dup [
+ [
+ \ drop ,
+ literal,
+ [ command-menu show-menu ] %
+ ] make-list
button-gestures
] [
2drop
] ifte ;
: <styled-label> ( style text -- label )
- <label> swap alist>hash over set-gadget-paint ;
+ <label> swap dup [ alist>hash ] when over set-gadget-paint ;
-: <presentation> ( style text pane -- presentation )
- pick gadget swap assoc dup [
- >r 3drop r>
- ] [
- drop >r <styled-label> dup r> init-commands
- ] ifte ;
+: <presentation> ( style text -- presentation )
+ gadget pick assoc dup
+ [ 2nip ] [ drop <styled-label> dup init-commands ] ifte ;
: gadget. ( gadget -- )
gadget swons unit "" swap write-attr ;
! need to be layout.
TUPLE: world running? hand glass invalid ;
+DEFER: <hand>
+
C: world ( -- world )
f <stack> over set-delegate
t over set-world-running?
M: world inside? ( point world -- ? ) 2drop t ;
-: hand world get world-hand ;
-
: draw-world ( world -- )
[
- dup
{ 0 0 0 } width get height get 0 3vector <rectangle> clip set
draw-gadget
] with-surface ;
: world-step ( -- ? )
world get dup world-invalid >r layout-world r>
- [ dup world-hand update-hand draw-world ] [ drop ] ifte ;
+ [ draw-world ] [ drop ] ifte ;
: next-event ( -- event ? )
<event> dup SDL_PollEvent ;
over f "picker" set-word-prop
over f "dispatcher" set-word-prop
(define-compound) ;
+
+: literalize ( word/obj -- quot )
+ #! Produce a quotation that pushes this object.
+ dup word? [ unit [ car ] ] [ f ] ifte cons ;