<li>New <code>sleep ( ms -- )</code> word pauses current thread for a number of milliseconds.</li>
<li>New <code>with-datastack ( stack word -- stack )</code> combinator.</li>
<li>New <code>cond ( conditions -- )</code> combinator. It behaves like a set of nested <code>ifte</code>s, and compiles if each branch has the same stack effect. See its documentation comment for details.</li>
+<li>Formally documented method combination (<code>G:</code> syntax) in handbook.
<li>Erlang/Termite-style concurrency library in <code>contrib/concurrency</code> (Chris Double).</li>
<li>Completely redid infix algebra in <code>conrib/algebra/</code>. Now, vector operations are possible
and the syntax doesn't use so many spaces. New way to write the quadratic formula:
- out of memory error when printing global namespace\r
- removing unneeded #label\r
- pprint trailing space regression\r
+- finish scrollbars\r
+- fix up the min thumb size hack\r
\r
+ ui:\r
\r
-- fix up the min thumb size hack\r
+- long lines of text fail in draw-surface\r
- only redraw dirty gadgets\r
- faster mouse tracking\r
-\r
- off-by-one error in pick-up?\r
- closing ui does not stop timers\r
- adding/removing timers automatically for animated gadgets\r
- the invalid recursion form case needs to be fixed, for inlines too\r
- #jump-f #jump-f-label\r
- re-introduce #target-label => #target optimization\r
-- recursion is iffy; no base case needs to throw an error, and if the\r
- stack at the recursive call doesn't match up, throw an error\r
+- recursion is iffy; if the stack at the recursive call doesn't match\r
+ up, throw an error\r
\r
+ kernel:\r
\r
}
Tests if \texttt{s1} starts or ends with \texttt{s1}. If \texttt{s1} is longer than \texttt{s2}, outputs \texttt{f}.
-\wordtable{
-\vocabulary{sequences}
-\ordinaryword{cut}{cut ( seq n -- s1 s2 )}
-}
-Outputs a pair of sequences that equal the original sequence when appended. The first sequence has length $n$, the second has length $l-n$ where $l$ is the length of the input.
-\begin{alltt}
- "Hello world" 5 cut .s
-\textbf{" world"
-"Hello"}
-\end{alltt}
-This word has a simple definition:
-\begin{verbatim}
-: cut ( n seq -- seq seq )
- [ head ] 2keep tail ;
-\end{verbatim}
\wordtable{
\vocabulary{sequences}
\ordinaryword{?head}{?head~( s1 s2 -- seq ?~)}
drop
] [
dup { "infer-effect" "base-case" "no-effect" }
- reset-props decompile
+ reset-props update-xt
] ifte ;
"/library/collections/queues.factor"
"/library/math/matrices.factor"
+ "/library/math/parse-numbers.factor"
"/library/words.factor"
"/library/vocabularies.factor"
"/library/io/directories.factor"
"/library/io/binary.factor"
- "/library/syntax/parse-numbers.factor"
"/library/syntax/parse-words.factor"
"/library/syntax/parse-errors.factor"
"/library/syntax/parser.factor"
"/library/io/logging.factor"
- "/library/tools/gensym.factor"
"/library/tools/interpreter.factor"
"/library/tools/debugger.factor"
"/library/tools/memory.factor"
"/library/tools/listener.factor"
- "/library/tools/word-tools.factor"
"/library/tools/walker.factor"
"/library/tools/jedit.factor"
-
- "/library/test/test.factor"
-
"/library/tools/annotations.factor"
"/library/tools/inspector.factor"
+ "/library/test/test.factor"
+
"/library/syntax/see.factor"
"/library/threads.factor"
{ ">bignum" "math" }
{ ">float" "math" }
{ "(fraction>)" "math-internals" }
- { "str>float" "parser" }
- { "(unparse-float)" "parser" }
+ { "string>float" "math-internals" }
+ { "float>string" "math-internals" }
{ "float>bits" "math" }
{ "double>bits" "math" }
{ "bits>float" "math" }
#! Append to the sequence being built with make-seq.
building get swap nappend ;
+: # ( n -- )
+ #! Only useful with "" make.
+ number>string % ;
+
! Building hashtables, and computing a transitive closure.
SYMBOL: hash-buffer
: compile-all ( -- ) [ try-compile ] each-word ;
-: decompile ( word -- )
- dup compiled? [
- "Decompiling " write dup . update-xt
- ] [
- drop
- ] ifte ;
-
: recompile ( word -- )
- dup decompile compile ;
+ dup update-xt compile ;
: compile-1 ( quot -- word )
#! Compute a quotation into an uninterned word, for testing
: define-class ( class metaclass -- )
dupd "metaclass" set-word-prop
dup types number-sort typemap get set-hash ;
+
+: implementors ( class -- list )
+ #! Find a list of generics that implement a method
+ #! specializing on this class.
+ [ "methods" word-prop ?hash ] word-subset-with ;
+
+: classes ( -- list )
+ #! Output a list of all defined classes.
+ [ metaclass ] word-subset ;
\r
: <page> ( list -- gadget )\r
[ tutorial-line ] map\r
- 1 <pile> [ add-gadgets ] keep\r
+ <pile> dup 1 over set-pack-fill [ add-gadgets ] keep\r
empty-border ;\r
\r
: tutorial-pages\r
! Copyright (C) 2004,2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: file-responder
-USING: html httpd kernel lists namespaces parser sequences
+USING: html httpd kernel lists math namespaces parser sequences
io strings ;
: serving-path ( filename -- filename )
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: html
-USING: generic http io kernel lists namespaces parser
+USING: generic http io kernel lists math namespaces parser
presentation sequences strings styles words ;
: html-entities ( -- alist )
[ "text-decoration: underline; " % ] when ;
: size-css, ( size -- )
- "font-size: " % number>string % "; " % ;
+ "font-size: " % # "; " % ;
: font-css, ( font -- )
"font-family: " % % "; " % ;
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: http-client
-USING: errors http kernel lists namespaces parser sequences
+USING: errors http kernel lists math namespaces parser sequences
io strings ;
: parse-host ( url -- host port )
[ (handle-request) serve-responder ] with-scope ;
: parse-request ( request -- )
- dup log
+ dup log-message
" " split1 dup [
" HTTP" split1 drop url>path secure-path dup [
swap handle-request
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: httpd
-USING: hashtables http kernel lists namespaces parser sequences
-io strings ;
+USING: hashtables http kernel lists math namespaces parser
+sequences io strings ;
! Variables
SYMBOL: vhosts
: log-user-agent ( alist -- )
"User-Agent" swap assoc* [
- unswons [ % ": " % % ] "" make log
+ unswons [ % ": " % % ] "" make log-message
] when* ;
: prepare-url ( url -- url )
"default" responder call-responder ;
: log-responder ( path -- )
- "Calling responder " swap append log ;
+ "Calling responder " swap append log-message ;
: trim-/ ( url -- url )
#! Trim a leading /, if there is one.
\ (fraction>) t "flushable" set-word-prop
\ (fraction>) t "foldable" set-word-prop
-\ str>float [ [ string ] [ float ] ] "infer-effect" set-word-prop
-\ str>float t "flushable" set-word-prop
-\ str>float t "foldable" set-word-prop
+\ string>float [ [ string ] [ float ] ] "infer-effect" set-word-prop
+\ string>float t "flushable" set-word-prop
+\ string>float t "foldable" set-word-prop
-\ (unparse-float) [ [ float ] [ string ] ] "infer-effect" set-word-prop
-\ (unparse-float) t "flushable" set-word-prop
-\ (unparse-float) t "foldable" set-word-prop
+\ float>string [ [ float ] [ string ] ] "infer-effect" set-word-prop
+\ float>string t "flushable" set-word-prop
+\ float>string t "foldable" set-word-prop
\ float>bits [ [ real ] [ integer ] ] "infer-effect" set-word-prop
\ float>bits t "flushable" set-word-prop
! Copyright (C) 2003, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: io
-USING: io kernel namespaces parser sequences strings ;
+USING: io kernel math namespaces parser sequences strings ;
! A simple logging framework.
SYMBOL: log-stream
-: log ( msg -- )
+: log-message ( msg -- )
#! Log a message to the log stream, either stdio or a file.
- log-stream get [
- [ stream-print ] keep stream-flush
- ] [
- print flush
- ] ifte* ;
+ log-stream get [ stdio get ] unless*
+ [ stream-print ] keep stream-flush ;
-: log-error ( error -- ) "Error: " swap append log ;
+: log-error ( error -- ) "Error: " swap append log-message ;
: log-client ( client-stream -- )
[
"Accepted connection from " %
dup client-stream-host %
CHAR: : ,
- client-stream-port number>string %
- ] "" make log ;
+ client-stream-port #
+ ] "" make log-message ;
: with-log-file ( file quot -- )
#! Calls to log inside quot will output to a file.
] [
dup 1 = [ drop 0 ] [ 2 /i log2 1 + ] ifte
] ifte ; foldable
+
+GENERIC: string>number ( str -- num ) foldable
+GENERIC: number>string ( str -- num ) foldable
--- /dev/null
+! Copyright (C) 2004, 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: math
+USING: errors generic kernel math-internals namespaces sequences
+strings ;
+
+! Number parsing
+
+: not-a-number "Not a number" throw ; inline
+
+GENERIC: digit> ( ch -- n )
+M: digit digit> CHAR: 0 - ;
+M: letter digit> CHAR: a - 10 + ;
+M: LETTER digit> CHAR: A - 10 + ;
+M: object digit> not-a-number ;
+
+: digit+ ( num digit base -- num )
+ 2dup < [ rot * + ] [ not-a-number ] ifte ;
+
+: (base>) ( base str -- num )
+ dup empty? [
+ not-a-number
+ ] [
+ 0 [ digit> pick digit+ ] reduce nip
+ ] ifte ;
+
+: base> ( str base -- num )
+ #! Convert a string to an integer. Throw an error if
+ #! conversion fails.
+ swap "-" ?head >r (base>) r> [ neg ] when ;
+
+M: string string>number 10 base> ;
+
+PREDICATE: string potential-ratio CHAR: / swap member? ;
+M: potential-ratio string>number ( str -- num )
+ "/" split1 >r 10 base> r> 10 base> / ;
+
+PREDICATE: string potential-float CHAR: . swap member? ;
+M: potential-float string>number ( str -- num ) string>float ;
+
+: bin> 2 base> ;
+: oct> 8 base> ;
+: hex> 16 base> ;
+
+: >digit ( n -- ch )
+ dup 10 < [ CHAR: 0 + ] [ 10 - CHAR: a + ] ifte ;
+
+: integer, ( num radix -- )
+ dup >r /mod >digit , dup 0 >
+ [ r> integer, ] [ r> 2drop ] ifte ;
+
+: >base ( num radix -- string )
+ #! Convert a number to a string in a certain base.
+ [
+ over 0 < [
+ swap neg swap integer, CHAR: - ,
+ ] [
+ integer,
+ ] ifte
+ ] "" make reverse ;
+
+: >bin ( num -- string ) 2 >base ;
+: >oct ( num -- string ) 8 >base ;
+: >hex ( num -- string ) 16 >base ;
+
+M: integer number>string ( obj -- str ) 10 >base ;
+
+M: ratio number>string ( num -- str )
+ [ dup numerator # CHAR: / , denominator # ] "" make ;
+
+M: float number>string ( float -- str )
+ #! This is terrible. Will go away when we do our own float
+ #! output.
+ float>string CHAR: . over member? [ ".0" append ] unless ;
FIELD: void* hwdata
FIELD: short clip-x
FIELD: short clip-y
- FIELD: ushort clip-w
- FIELD: ushort clip-h
+ FIELD: ushort clip-w
+ FIELD: ushort clip-h
FIELD: uint unused1
FIELD: uint locked
FIELD: int map
+++ /dev/null
-! Copyright (C) 2004, 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: parser
-USING: errors generic kernel math namespaces sequences strings ;
-
-! Number parsing
-
-: not-a-number "Not a number" throw ; inline
-
-GENERIC: digit> ( ch -- n )
-M: digit digit> CHAR: 0 - ;
-M: letter digit> CHAR: a - 10 + ;
-M: LETTER digit> CHAR: A - 10 + ;
-M: object digit> not-a-number ;
-
-: digit+ ( num digit base -- num )
- 2dup < [ rot * + ] [ not-a-number ] ifte ;
-
-: (base>) ( base str -- num )
- dup empty? [
- not-a-number
- ] [
- 0 [ digit> pick digit+ ] reduce nip
- ] ifte ;
-
-: base> ( str base -- num )
- #! Convert a string to an integer. Throw an error if
- #! conversion fails.
- swap "-" ?head [ (base>) neg ] [ (base>) ] ifte ;
-
-GENERIC: string>number ( str -- num )
-
-M: string string>number 10 base> ;
-
-PREDICATE: string potential-ratio CHAR: / swap member? ;
-M: potential-ratio string>number ( str -- num )
- "/" split1 >r 10 base> r> 10 base> / ;
-
-PREDICATE: string potential-float CHAR: . swap member? ;
-M: potential-float string>number ( str -- num )
- str>float ;
-
-: bin> 2 base> ;
-: oct> 8 base> ;
-: hex> 16 base> ;
-
-GENERIC: number>string ( str -- num )
-
-: >digit ( n -- ch )
- dup 10 < [ CHAR: 0 + ] [ 10 - CHAR: a + ] ifte ;
-
-: integer, ( num radix -- )
- dup >r /mod >digit , dup 0 > [
- r> integer,
- ] [
- r> 2drop
- ] ifte ;
-
-: >base ( num radix -- string )
- #! Convert a number to a string in a certain base.
- [
- over 0 < [
- swap neg swap integer, CHAR: - ,
- ] [
- integer,
- ] ifte
- ] "" make reverse ;
-
-: >bin ( num -- string ) 2 >base ;
-: >oct ( num -- string ) 8 >base ;
-: >hex ( num -- string ) 16 >base ;
-
-M: integer number>string ( obj -- str ) 10 >base ;
-
-M: ratio number>string ( num -- str )
- [
- dup
- numerator number>string %
- CHAR: / ,
- denominator number>string %
- ] "" make ;
-
-: fix-float ( str -- str )
- #! This is terrible. Will go away when we do our own float
- #! output.
- CHAR: . over member? [ ".0" append ] unless ;
-
-M: float number>string ( float -- str )
- (unparse-float) fix-float ;
! Copyright (C) 2004, 2005 Slava Pestov.\r
! See http://factor.sf.net/license.txt for BSD license.\r
IN: parser\r
-USING: kernel lists namespaces sequences io ;\r
+USING: kernel lists namespaces sequences io words ;\r
\r
: file-vocabs ( -- )\r
"scratchpad" "in" set\r
\r
: run-resource ( file -- )\r
parse-resource call ;\r
+\r
+: word-file ( word -- file )\r
+ "file" word-prop dup [\r
+ "resource:/" ?head [ resource-path swap path+ ] when\r
+ ] when ;\r
+\r
+: reload ( word -- )\r
+ #! Reload the source file the word originated from.\r
+ word-file run-file ;\r
SYMBOL: recursion-check
SYMBOL: line-count
SYMBOL: end-printing
-SYMBOL: newline-ok?
! Configuration
SYMBOL: tab-size
0 last-newline set
0 line-count set
string-limit off
- newline-ok? off
] bind
TUPLE: pprinter stack ;
: section-fits? ( section -- ? )
section-end last-newline get - indent get + margin get <= ;
-: insert-newline? ( section -- ? )
- section-fits? not newline-ok? and ;
-
: line-limit? ( -- ? )
line-limit get dup [ line-count get <= ] when ;
: fresh-line ( n -- )
#! n is current column position.
- last-newline set
- line-count inc
- line-limit? [ "..." write end-printing get call ] when
- "\n" write do-indent ;
+ dup last-newline get = [
+ drop
+ ] [
+ last-newline set
+ line-count inc
+ line-limit? [ "..." write end-printing get call ] when
+ "\n" write do-indent
+ ] ifte ;
TUPLE: text string style ;
[ set-text-string ] keep ;
M: text pprint-section*
- dup text-string swap text-style format " " write ;
+ dup text-string swap text-style format " " write ;
TUPLE: block sections ;
[ section-end fresh-line ] [ drop ] ifte ;
: pprint-section ( section -- )
- dup insert-newline? newline-ok? on
- [ inset-section ] [ pprint-section* ] ifte ;
+ dup section-fits?
+ [ pprint-section* ] [ inset-section ] ifte ;
TUPLE: newline ;
0 <section> over set-delegate ;
M: newline pprint-section* ( newline -- )
- section-start fresh-line newline-ok? off ;
+ section-start fresh-line ;
M: block pprint-section* ( block -- )
block-sections [ pprint-section ] each ;
: see ( word -- )
[ dup in. dup (see) dup class. methods. ] with-pprint ;
+
+: (apropos) ( substring -- seq )
+ vocabs [
+ words [ word-name subseq? ] subset-with
+ ] map-with concat ;
+
+: apropos ( substring -- )
+ #! List all words that contain a string.
+ (apropos) [
+ "IN: " write dup word-vocabulary write " " write .
+ ] each ;
#! Evaluates the given code and prints the time taken to
#! execute it.
millis >r gc-time >r call gc-time r> - millis r> -
- [
- number>string % " ms run / " %
- number>string % " ms GC time" %
- ] "" make print ;
+ [ # " ms run / " % # " ms GC time" % ] "" make print ;
: unit-test ( output input -- )
[
+++ /dev/null
-! Copyright (C) 2004, 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: words
-USING: hashtables kernel math namespaces parser sequences
-strings ;
-
-: gensym ( -- word )
- #! Return a word that is distinct from every other word, and
- #! is not contained in any vocabulary.
- "G:"
- global [ \ gensym dup inc get ] bind
- number>string append f <word> ;
-
-0 \ gensym global set-hash
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: jedit
-USING: errors io kernel lists namespaces parser prettyprint
+USING: errors io kernel lists math namespaces parser prettyprint
sequences strings unparser vectors words ;
! Some words to send requests to a running jEdit instance to
! Copyright (C) 2003, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: telnetd
-USING: errors listener kernel namespaces io threads parser ;
+USING: errors listener kernel math namespaces io threads parser ;
: telnet-client ( socket -- )
dup [ log-client print-banner listener ] with-stream ;
+++ /dev/null
-! Copyright (C) 2003, 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: words
-USING: generic inspector lists kernel namespaces
-prettyprint io strings sequences math hashtables parser ;
-
-: vocab-apropos ( substring vocab -- list )
- #! Push a list of all words in a vocabulary whose names
- #! contain a string.
- words [ word-name subseq? ] subset-with ;
-
-: vocab-apropos. ( substring vocab -- )
- #! List all words in a vocabulary that contain a string.
- tuck vocab-apropos dup [
- "IN: " write swap print sequence.
- ] [
- 2drop
- ] ifte ;
-
-: apropos. ( substring -- )
- #! List all words that contain a string.
- vocabs [ vocab-apropos. ] each-with ;
-
-: word-file ( word -- file )
- "file" word-prop dup [
- "resource:/" ?head [
- resource-path swap path+
- ] when
- ] when ;
-
-: reload ( word -- )
- #! Reload the source file the word originated from.
- word-file run-file ;
-
-: implementors ( class -- list )
- #! Find a list of generics that implement a method
- #! specializing on this class.
- [
- "methods" word-prop [ dupd hash ] [ f ] ifte*
- ] word-subset nip ;
-
-: classes ( -- list )
- [ metaclass ] word-subset ;
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
-IN: gadgets
-USING: generic kernel lists math matrices sequences ;
+IN: gadgets-books
+USING: gadgets gadgets-buttons gadgets-labels gadgets-layouts
+generic kernel lists math matrices sequences ;
TUPLE: book page ;
{ ">" [ find-book next-page ] }
{ ">|" [ find-book last-page ] }
] [ 2unseq >r <label> r> <button> ] map
- 0 <shelf> [ add-gadgets ] keep ;
+ <shelf> [ add-gadgets ] keep ;
C: book-browser ( book -- gadget )
<frame> over set-delegate
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
-IN: gadgets
-USING: errors generic hashtables kernel lists math matrices
+IN: gadgets-borders
+USING: errors gadgets generic hashtables kernel lists math
namespaces sdl vectors ;
TUPLE: border size ;
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
-IN: gadgets
-USING: generic io kernel lists math namespaces prettyprint sdl
-sequences sequences styles threads ;
+IN: gadgets-buttons
+USING: gadgets gadgets-borders generic io kernel lists math
+namespaces sdl sequences sequences styles threads ;
: button-down? ( n -- ? ) hand hand-buttons member? ;
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
-IN: gadgets
-USING: generic kernel math matrices namespaces sdl sequences
-strings styles threads vectors ;
+IN: gadgets-editors
+USING: gadgets gadgets-labels gadgets-scrolling generic kernel
+math namespaces sdl sequences strings styles threads vectors ;
! A blinking caret
TUPLE: caret ;
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
-IN: gadgets
-USING: generic kernel lists math namespaces sequences vectors ;
+IN: gadgets-layouts
+USING: gadgets generic kernel lists math namespaces sequences
+vectors ;
! A frame arranges gadgets in a 3x3 grid, where the center
! gadgets gets left-over space.
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
-IN: gadgets
-USING: generic kernel math ;
+IN: gadgets-layouts
+USING: gadgets generic kernel math ;
! Incremental layout allows adding lines to panes to be O(1).
! Note that incremental packs are distinct from ordinary packs
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
-IN: gadgets
-USING: generic hashtables io kernel lists math namespaces sdl
-sequences styles vectors ;
+IN: gadgets-labels
+USING: gadgets generic hashtables io kernel lists math
+namespaces sdl sequences styles vectors ;
! A label gadget draws a string.
TUPLE: label text ;
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
-IN: gadgets
-USING: errors generic hashtables kernel lists math matrices
-namespaces sdl sequences ;
+IN: gadgets-layouts
+USING: errors gadgets generic hashtables kernel lists math
+matrices namespaces sdl sequences ;
: layout ( gadget -- )
#! Set the gadget's width and height to its preferred width
>r >r pack-vector r> r> [ pick set-axis ] 2map nip ;
: packed-dim-2 ( gadget sizes -- list )
- [
- over rect-dim { 1 1 1 } vmax over v-
- rot pack-fill v*n v+
- ] map-with ;
-
-: (packed-dims) ( gadget sizes -- seq )
- 2dup packed-dim-2 swap orient ;
+ [ over rect-dim over v- rot pack-fill v*n v+ ] map-with ;
: packed-dims ( gadget sizes -- seq )
- over gadget-children >r (packed-dims) r>
- [ set-gadget-dim ] 2each ;
+ 2dup packed-dim-2 swap orient ;
: packed-loc-1 ( sizes -- seq )
{ 0 0 0 } [ v+ ] accumulate ;
: packed-loc-2 ( gadget sizes -- seq )
- >r dup rect-dim { 1 1 1 } vmax over r>
- packed-dim-2 [ v- ] map-with
- >r dup pack-align swap rect-dim { 1 1 1 } vmax r>
- [ >r 2dup r> v- n*v ] map 2nip ;
+ [ >r dup pack-align swap rect-dim r> v- n*v ] map-with ;
-: (packed-locs) ( gadget sizes -- seq )
+: packed-locs ( gadget sizes -- seq )
dup packed-loc-1 >r dupd packed-loc-2 r> orient ;
-: packed-locs ( gadget sizes -- )
- over gadget-children >r (packed-locs) r>
- [ set-rect-loc ] 2each ;
-
: packed-layout ( gadget sizes -- )
- 2dup packed-locs packed-dims ;
+ over gadget-children
+ >r dupd packed-dims r> 2dup [ set-gadget-dim ] 2each
+ >r packed-locs r> [ set-rect-loc ] 2each ;
C: pack ( fill vector -- pack )
#! gap: between each child.
[ set-pack-fill ] keep
0 over set-pack-align ;
-: <pile> (
fill -- pack ) { 0 1 0 } <pack> ;
+: <pile> ( -- pack ) { 0 1 0 } <pack> ;
-: <shelf> (
fill -- pack ) { 1 0 0 } <pack> ;
+: <shelf> ( -- pack ) { 1 0 0 } <pack> ;
M: pack pref-dim ( pack -- dim )
[
C: stack ( -- gadget )
#! A stack lays out all its children on top of each other.
- 1 { 0 0 1 } <pack> over set-delegate ;
+ { 0 0 1 } <pack> over set-delegate
+ 1 over set-pack-fill ;
M: stack children-on ( point stack -- gadget )
nip gadget-children ;
IN: help
DEFER: <tutorial-button>
-IN: gadgets
-USING: generic help io kernel listener lists math namespaces
+IN: gadgets-listener
+USING: gadgets gadgets-labels gadgets-layouts gadgets-panes
+gadgets-presentations gadgets-scrolling gadgets-splitters
+generic help io kernel listener lists math namespaces
prettyprint sdl sequences shells styles threads words ;
SYMBOL: datastack-display
C: display ( -- display )
<frame> over set-delegate
"" <display-title> over add-display-title
-
0 <pile> 2dup swap set-display-pane
+ <pile> 2dup swap set-display-pane
<scroller> over add-center ;
: make-presentations ( seq -- seq )
- [
- dup presented swons unit swap unparse-short
- <presentation>
- ] map ;
+ [ <object-presentation> ] map ;
: present-stack ( seq title display -- )
[ display-title set-label-text ] keep
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
-IN: gadgets
-USING: generic kernel lists math namespaces sequences ;
+IN: gadgets-menus
+USING: gadgets gadgets-borders gadgets-buttons gadgets-layouts
+gadgets-labels generic kernel lists math namespaces sequences ;
: menu-actions ( glass -- )
[ drop hide-glass ] [ button-down 1 ] set-action ;
#! Given an association list mapping labels to quotations.
#! Prepend a call to hide-menu to each quotation.
[ uncons \ hide-glass swons >r <label> r> <roll-button> ] map
- 1 <pile> [ add-gadgets ] keep ;
+ <pile> 1 over set-pack-fill [ add-gadgets ] keep ;
: menu-theme ( menu -- )
<< solid f >> interior set-paint-prop ;
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
-IN: gadgets
-USING: generic hashtables io kernel line-editor listener lists
+IN: gadgets-panes
+USING: gadgets gadgets-editors gadgets-labels gadgets-layouts
+gadgets-scrolling generic hashtables io kernel line-editor lists
math namespaces prettyprint sequences strings styles threads
vectors ;
: add-input 2dup set-pane-input add-gadget ;
: <active-line> ( input current -- line )
- 2vector 0 <shelf> [ add-gadgets ] keep ;
+ 2vector <shelf> [ add-gadgets ] keep ;
: init-active-line ( pane -- )
dup pane-active unparent
: pane-return ( pane -- )
[ pane-input editor-commit ] keep
2dup stream-print pane-eval ;
+
+: pane-clear ( pane -- )
+ dup pane-output clear-incremental pane-current clear-gadget ;
: pane-actions ( line -- )
[
[[ [ "RETURN" ] [ pane-return ] ]]
[[ [ "UP" ] [ pane-input [ history-prev ] with-editor ] ]]
[[ [ "DOWN" ] [ pane-input [ history-next ] with-editor ] ]]
+ [[ [ "CTRL" "l" ] [ pane get pane-clear ] ]]
] swap add-actions ;
C: pane ( -- pane )
-
0 <pile> over set-delegate
-
0 <pile> <incremental> over add-output
- 0 <shelf> over set-pane-current
+ <pile> over set-delegate
+ <pile> <incremental> over add-output
+ <shelf> over set-pane-current
"" <editor> over set-pane-input
dup init-active-line
dup pane-actions ;
M: pane focusable-child* ( pane -- editor )
pane-input ;
-: pane-clear ( pane -- )
- dup pane-output clear-incremental pane-current clear-gadget ;
-
: pane-write-1 ( style text pane -- )
pick not pick empty? and [
3drop
: pane-terpri ( pane -- )
dup pane-current over pane-print-1
- 0 <shelf> over set-pane-current init-active-line ;
+ <shelf> over set-pane-current init-active-line ;
: pane-write ( style pane list -- )
3dup car swap pane-write-1 cdr dup
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
-IN: gadgets
-USING: compiler generic hashtables inference inspector io jedit
-kernel lists memory namespaces parser prettyprint sequences
-styles vectors words ;
+IN: gadgets-presentations
+USING: compiler gadgets gadgets-buttons gadgets-labels
+gadgets-menus gadgets-panes generic hashtables inference
+inspector io jedit kernel lists memory namespaces parser
+prettyprint sequences styles vectors words ;
SYMBOL: commands
gadget pick assoc dup
[ 2nip ] [ drop <styled-label> init-commands ] ifte ;
+: <object-presentation> ( object -- gadget )
+ dup presented swons unit swap unparse-short <presentation> ;
+
: gadget. ( gadget -- )
gadget swons unit
"This stream does not support live gadgets"
[ compound? ] "Annotate with breakpoint" [ break ] define-command
[ compound? ] "Annotate with profiling" [ profile ] define-command
[ word? ] "Compile" [ recompile ] define-command
-[ word? ] "Decompile" [ decompile ] define-command
[ word? ] "Show stack effect" [ unit infer . ] define-command
[ word? ] "Show dataflow IR" [ word-def t dataflow. ] define-command
[ word? ] "Show linear IR" [ precompile ] define-command
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
-IN: gadgets
-USING: generic kernel lists math matrices namespaces sequences
-threads vectors styles ;
+IN: gadgets-scrolling
+USING: gadgets gadgets-layouts generic kernel lists math
+namespaces sequences threads vectors styles ;
! A viewport can be scrolled.
TUPLE: viewport ;
M: scroller layout* ( scroller -- )
dup scroller-bottom? [
f over set-scroller-bottom?
- dup dup scroller-viewport viewport-dim scroll
+ dup dup scroller-viewport viewport-dim
+ { 0 1 0 } v* scroll
] when delegate layout* ;
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
-IN: gadgets
-USING: generic kernel lists math matrices namespaces sequences
-threads vectors styles ;
+IN: gadgets-scrolling
+USING: gadgets gadgets-buttons gadgets-layouts generic kernel
+lists math namespaces sequences threads vectors styles ;
! An elevator has a thumb that may be moved up and down.
TUPLE: elevator ;
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
-IN: gadgets
-USING: generic kernel lists math matrices namespaces sequences
-styles vectors ;
+IN: gadgets-splitters
+USING: gadgets gadgets-layouts generic kernel lists math
+namespaces sequences styles vectors ;
TUPLE: divider splitter ;
dup divider-actions ;
C: splitter ( first second split vector -- splitter )
- [ >r
1 swap <pack> r> set-delegate ] keep
+ [ >r <pack> r> set-delegate ] keep
[ set-splitter-split ] keep
- [ >r >r <divider> r> 3vector r> add-gadgets ] keep ;
+ [ >r >r <divider> r> 3vector r> add-gadgets ] keep
+ 1 over set-pack-fill ;
: <x-splitter> ( first second split -- splitter )
{ 0 1 0 } <splitter> ;
: draw-surface ( x y surface -- )
surface get SDL_UnlockSurface
- [
- [ surface-rect ] keep swap surface get 0 0
- ] keep surface-rect swap rot SDL_UpperBlit drop
- surface get dup must-lock-surface? [
- SDL_LockSurface
- ] when drop ;
+ [ [ surface-rect ] keep swap surface get 0 0 ] keep
+ surface-rect swap rot SDL_UpperBlit drop
+ surface get dup must-lock-surface?
+ [ SDL_LockSurface ] when drop ;
: filter-nulls ( str -- str )
[ dup 0 = [ drop CHAR: \s ] when ] map ;
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: gadgets
-USING: generic help io kernel listener lists math namespaces
-prettyprint sdl sequences shells styles threads words ;
+USING: gadgets-listener generic help io kernel listener lists
+math namespaces prettyprint sdl sequences shells styles threads
+words ;
: init-world
global [
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: gadgets
-USING: alien errors generic io kernel lists math memory
-namespaces prettyprint sdl sequences sequences strings threads
-vectors ;
+USING: alien errors gadgets-layouts generic io kernel lists math
+memory namespaces prettyprint sdl sequences sequences strings
+threads vectors ;
! The world gadget is the top level gadget that all (visible)
! gadgets are contained in. The current world is stored in the
dup port-error f rot set-port-error throw ;
: report-error ( error port -- )
- [
- "Error on fd " %
- dup port-handle number>string %
- ": " % swap %
- ] "" make swap set-port-error ;
+ [ "Error on fd " % dup port-handle # ": " % swap % ] "" make
+ swap set-port-error ;
: defer-error ( port -- ? )
#! Return t if it is an unrecoverable error.
: inet-ntoa ( n -- str )
ntohl [
- dup -24 shift HEX: ff bitand number>string % CHAR: . ,
- dup -16 shift HEX: ff bitand number>string % CHAR: . ,
- dup -8 shift HEX: ff bitand number>string % CHAR: . ,
- HEX: ff bitand number>string %
+ dup -24 shift HEX: ff bitand # CHAR: . ,
+ dup -16 shift HEX: ff bitand # CHAR: . ,
+ dup -8 shift HEX: ff bitand # CHAR: . ,
+ HEX: ff bitand #
] "" make ;
: do-accept ( port sockaddr fd -- )
#! Sort a list of words by name.
[ swap word-name swap word-name lexi ] sort ;
+: uses ( word -- uses )
+ #! Outputs a list of words that this word directly calls.
+ [
+ dup word-def [
+ dup word? [ 2dup eq? [ dup , ] unless ] when 2drop
+ ] tree-each-with
+ ] { } make prune ;
+
! The cross-referencer keeps track of word dependencies, so that
! words can be recompiled when redefined.
SYMBOL: crossref
-: (add-crossref)
- dup word? [
- crossref get [ dupd nest set-hash ] bind
- ] [
- 2drop
- ] ifte ;
+: (add-crossref) crossref get [ dupd nest set-hash ] bind ;
: add-crossref ( word -- )
#! Marks each word in the quotation as being a dependency
#! of the word.
crossref get [
- dup word-def [ (add-crossref) ] tree-each-with
+ dup uses [ (add-crossref) ] each-with
] [
drop
] ifte ;
-: (remove-crossref)
- dup word? [
- crossref get [ nest remove-hash ] bind
- ] [
- 2drop
- ] ifte ;
+: (remove-crossref) crossref get [ nest remove-hash ] bind ;
: remove-crossref ( word -- )
#! Marks each word in the quotation as not being a
#! dependency of the word.
crossref get [
- dup word-def [ (remove-crossref) ] tree-each-with
+ dup uses [ (remove-crossref) ] each-with
] [
drop
] ifte ;
M: word literalize <wrapper> ;
M: wrapper literalize <wrapper> ;
+
+: gensym ( -- word )
+ #! Return a word that is distinct from every other word, and
+ #! is not contained in any vocabulary.
+ "G:"
+ global [ \ gensym dup inc get ] bind
+ number>string append f <word> ;
+
+0 \ gensym global set-hash
projects / factor.git / commitdiff