+- workspace window takes too long to come up
+
+ 0.87:
- live search: timer delay would be nice
+ compiler/ffi:
+- recompile get/set/>n/n>/ndrop if needed
- %allot-bignum-signed-2 is broken on both platforms
- cross-word type inference
- callback scheduling issue
+++ /dev/null
-! Copyright (C) 2005 Chris Double.
-!
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice,
-! this list of conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-! this list of conditions and the following disclaimer in the documentation
-! and/or other materials provided with the distribution.
-!
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-!
-IN: coroutines
-USING: kernel generic ;
-
-TUPLE: coroutine resumecc exitcc ;
-
-: cocreate ( quot -- co )
- #! Create a new coroutine, which will execute the quotation
- #! when resumed. The quotation will have the coroutine
- #! on the stack and an initial value (received from coresume)
- #! when first resumed. ie. The quotation should have stack
- #! effect ( co value -- ).
- f f <coroutine> dup rot curry over set-coroutine-resumecc ;
-
-: coresume ( v co -- result )
- #! Resume a coroutine with 'v' as the first item on the
- #! stack. The result placed on the stack is that of the
- #! topmost argument on the stack when coyield is called
- #! within the coroutine.
- [
- over set-coroutine-exitcc
- coroutine-resumecc call
- ] callcc1 rot drop ;
-
-: coyield ( v co -- result )
- #! Suspend a coroutine, leaving the value 'v' on the
- #! stack when control is passed to the 'coresume' caller.
- [
- [ continue-with ] curry
- over set-coroutine-resumecc
- coroutine-exitcc continue-with
- ] callcc1 rot drop ;
-
-USE: prettyprint
-USE: sequences
-
-: test1 ( list -- co )
- [ swap [ over coyield 2drop ] each f swap coyield ] cocreate ;
-
-: test2 ( -- co )
- [ 1 over coyield drop 2 over coyield drop 3 over coyield ] cocreate ;
-
-test2 f swap coresume . f swap coresume . f swap coresume . drop
-
-: test3 ( -- co )
- [ [ 1 2 3 ] [ over coyield drop ] each ] cocreate ;
-
-test3 f swap coresume . f swap coresume . f swap coresume . drop
-
-PROVIDE: contrib/coroutines ;
-
--- /dev/null
+! Copyright (C) 2005 Chris Double.
+!
+! Redistribution and use in source and binary forms, with or without
+! modification, are permitted provided that the following conditions are met:
+!
+! 1. Redistributions of source code must retain the above copyright notice,
+! this list of conditions and the following disclaimer.
+!
+! 2. Redistributions in binary form must reproduce the above copyright notice,
+! this list of conditions and the following disclaimer in the documentation
+! and/or other materials provided with the distribution.
+!
+! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+!
+IN: coroutines
+USING: kernel generic ;
+
+TUPLE: coroutine resumecc exitcc ;
+
+: cocreate ( quot -- co )
+ #! Create a new coroutine, which will execute the quotation
+ #! when resumed. The quotation will have the coroutine
+ #! on the stack and an initial value (received from coresume)
+ #! when first resumed. ie. The quotation should have stack
+ #! effect ( co value -- ).
+ f f <coroutine> dup rot curry over set-coroutine-resumecc ;
+
+: coresume ( v co -- result )
+ #! Resume a coroutine with 'v' as the first item on the
+ #! stack. The result placed on the stack is that of the
+ #! topmost argument on the stack when coyield is called
+ #! within the coroutine.
+ [
+ over set-coroutine-exitcc
+ coroutine-resumecc call
+ ] callcc1 rot drop ;
+
+: coyield ( v co -- result )
+ #! Suspend a coroutine, leaving the value 'v' on the
+ #! stack when control is passed to the 'coresume' caller.
+ [
+ [ continue-with ] curry
+ over set-coroutine-resumecc
+ coroutine-exitcc continue-with
+ ] callcc1 rot drop ;
--- /dev/null
+PROVIDE: contrib/coroutines
+{ +files+ { "coroutines.factor" } }
+{ +tests+ { "tests.factor" } } ;
--- /dev/null
+IN: temporary
+USING: coroutines kernel sequences prettyprint ;
+
+: test1 ( list -- co )
+ [ swap [ over coyield 2drop ] each f swap coyield ] cocreate ;
+
+: test2 ( -- co )
+ [ 1 over coyield drop 2 over coyield drop 3 over coyield ] cocreate ;
+
+test2 f swap coresume . f swap coresume . f swap coresume . drop
+
+: test3 ( -- co )
+ [ [ 1 2 3 ] [ over coyield drop ] each ] cocreate ;
+
+test3 f swap coresume . f swap coresume . f swap coresume . drop
stack-effect dup [
nip effect-in length
] [
- drop infer first
+ drop infer effect-in length nip
] if ;
: make-lazy-quot ( word quot -- quot )
+++ /dev/null
-! Copyright (c) 2005 Mackenzie Straight.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: splay-trees
-USING: kernel math sequences ;
-
-TUPLE: splay-tree r ;
-TUPLE: splay-node v k l r ;
-
-C: splay-tree ;
-
-: rotate-right
- dup splay-node-l
- [ splay-node-r swap set-splay-node-l ] 2keep
- [ set-splay-node-r ] keep ;
-
-: rotate-left
- dup splay-node-r
- [ splay-node-l swap set-splay-node-r ] 2keep
- [ set-splay-node-l ] keep ;
-
-: link-right ( left right key node -- left right key node )
- swap >r [ swap set-splay-node-l ] 2keep
- nip dup splay-node-l r> swap ;
-
-: link-left ( left right key node -- left right key node )
- swap >r rot [ set-splay-node-r ] 2keep
- drop dup splay-node-r swapd r> swap ;
-
-: cmp 2dup splay-node-k <=> ;
-
-: lcmp 2dup splay-node-l splay-node-k <=> ;
-
-: rcmp 2dup splay-node-r splay-node-k <=> ;
-
-DEFER: (splay)
-
-: splay-left
- dup splay-node-l [
- lcmp 0 < [ rotate-right ] when
- dup splay-node-l [ link-right (splay) ] when
- ] when ;
-
-: splay-right
- dup splay-node-r [
- rcmp 0 > [ rotate-left ] when
- dup splay-node-r [ link-left (splay) ] when
- ] when ;
-
-: (splay) ( left right key node -- left right key node )
- cmp dup 0 <
- [ drop splay-left ] [ 0 > [ splay-right ] when ] if ;
-
-: assemble ( head left right node -- root )
- [ splay-node-r swap set-splay-node-l ] keep
- [ splay-node-l swap set-splay-node-r ] keep
- [ swap splay-node-l swap set-splay-node-r ] 2keep
- [ swap splay-node-r swap set-splay-node-l ] keep ;
-
-: splay-at ( key node -- node )
- >r >r T{ splay-node } dup dup r> r> (splay) nip assemble ;
-
-: splay ( key tree -- )
- [ splay-tree-r splay-at ] keep set-splay-tree-r ;
-
-: splay-split ( key tree -- node node )
- 2dup splay splay-tree-r cmp 0 < [
- nip dup splay-node-l swap f over set-splay-node-l
- ] [
- nip dup splay-node-r swap f over set-splay-node-r swap
- ] if ;
-
-: (get-splay) ( key tree -- node )
- 2dup splay splay-tree-r cmp 0 = [ nip ] [ 2drop f ] if ;
-
-: get-largest ( node -- node )
- dup [ dup splay-node-r [ nip get-largest ] when* ] when ;
-
-: splay-largest
- dup [ dup get-largest splay-node-k swap splay-at ] when ;
-
-: splay-join ( n2 n1 -- node )
- splay-largest [ [ set-splay-node-r ] keep ] [ drop f ] if* ;
-
-: (remove-splay) ( key tree -- )
- tuck (get-splay) [
- dup splay-node-r swap splay-node-l splay-join
- swap set-splay-tree-r
- ] [ drop ] if* ;
-
-: (set-splay) ( value key tree -- )
- 2dup (get-splay) [ 2nip set-splay-node-v ] [
- 2dup splay-split rot >r <splay-node> r> set-splay-tree-r
- ] if* ;
-
-: new-root ( value key tree -- )
- >r f f <splay-node> r> set-splay-tree-r ;
-
-: set-splay ( value key tree -- )
- dup splay-tree-r [ (set-splay) ] [ new-root ] if ;
-
-: get-splay ( key tree -- value )
- dup splay-tree-r [
- (get-splay) dup [ splay-node-v ] when
- ] [
- 2drop f
- ] if ;
-
-: remove-splay ( key tree -- )
- dup splay-tree-r [ (remove-splay) ] [ 2drop ] if ;
-
-USING: namespaces words ;
-
-<splay-tree> "foo" set
-all-words [ dup word-name "foo" get set-splay ] each
-all-words [ word-name "foo" get get-splay drop ] each
-
-PROVIDE: contrib/splay-trees ;
--- /dev/null
+PROVIDE: contrib/splay-trees
+{ +files+ { "splay-trees.factor" } }
+{ +tests+ { "tests.factor" } } ;
--- /dev/null
+! Copyright (c) 2005 Mackenzie Straight.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: splay-trees
+USING: kernel math sequences ;
+
+TUPLE: splay-tree r ;
+TUPLE: splay-node v k l r ;
+
+C: splay-tree ;
+
+: rotate-right
+ dup splay-node-l
+ [ splay-node-r swap set-splay-node-l ] 2keep
+ [ set-splay-node-r ] keep ;
+
+: rotate-left
+ dup splay-node-r
+ [ splay-node-l swap set-splay-node-r ] 2keep
+ [ set-splay-node-l ] keep ;
+
+: link-right ( left right key node -- left right key node )
+ swap >r [ swap set-splay-node-l ] 2keep
+ nip dup splay-node-l r> swap ;
+
+: link-left ( left right key node -- left right key node )
+ swap >r rot [ set-splay-node-r ] 2keep
+ drop dup splay-node-r swapd r> swap ;
+
+: cmp 2dup splay-node-k <=> ;
+
+: lcmp 2dup splay-node-l splay-node-k <=> ;
+
+: rcmp 2dup splay-node-r splay-node-k <=> ;
+
+DEFER: (splay)
+
+: splay-left
+ dup splay-node-l [
+ lcmp 0 < [ rotate-right ] when
+ dup splay-node-l [ link-right (splay) ] when
+ ] when ;
+
+: splay-right
+ dup splay-node-r [
+ rcmp 0 > [ rotate-left ] when
+ dup splay-node-r [ link-left (splay) ] when
+ ] when ;
+
+: (splay) ( left right key node -- left right key node )
+ cmp dup 0 <
+ [ drop splay-left ] [ 0 > [ splay-right ] when ] if ;
+
+: assemble ( head left right node -- root )
+ [ splay-node-r swap set-splay-node-l ] keep
+ [ splay-node-l swap set-splay-node-r ] keep
+ [ swap splay-node-l swap set-splay-node-r ] 2keep
+ [ swap splay-node-r swap set-splay-node-l ] keep ;
+
+: splay-at ( key node -- node )
+ >r >r T{ splay-node } dup dup r> r> (splay) nip assemble ;
+
+: splay ( key tree -- )
+ [ splay-tree-r splay-at ] keep set-splay-tree-r ;
+
+: splay-split ( key tree -- node node )
+ 2dup splay splay-tree-r cmp 0 < [
+ nip dup splay-node-l swap f over set-splay-node-l
+ ] [
+ nip dup splay-node-r swap f over set-splay-node-r swap
+ ] if ;
+
+: (get-splay) ( key tree -- node )
+ 2dup splay splay-tree-r cmp 0 = [ nip ] [ 2drop f ] if ;
+
+: get-largest ( node -- node )
+ dup [ dup splay-node-r [ nip get-largest ] when* ] when ;
+
+: splay-largest
+ dup [ dup get-largest splay-node-k swap splay-at ] when ;
+
+: splay-join ( n2 n1 -- node )
+ splay-largest [ [ set-splay-node-r ] keep ] [ drop f ] if* ;
+
+: (remove-splay) ( key tree -- )
+ tuck (get-splay) [
+ dup splay-node-r swap splay-node-l splay-join
+ swap set-splay-tree-r
+ ] [ drop ] if* ;
+
+: (set-splay) ( value key tree -- )
+ 2dup (get-splay) [ 2nip set-splay-node-v ] [
+ 2dup splay-split rot >r <splay-node> r> set-splay-tree-r
+ ] if* ;
+
+: new-root ( value key tree -- )
+ >r f f <splay-node> r> set-splay-tree-r ;
+
+: set-splay ( value key tree -- )
+ dup splay-tree-r [ (set-splay) ] [ new-root ] if ;
+
+: get-splay ( key tree -- value )
+ dup splay-tree-r [
+ (get-splay) dup [ splay-node-v ] when
+ ] [
+ 2drop f
+ ] if ;
+
+: remove-splay ( key tree -- )
+ dup splay-tree-r [ (remove-splay) ] [ 2drop ] if ;
--- /dev/null
+USING: splay-trees namespaces sequences kernel namespaces words ;
+
+<splay-tree> "foo" set
+all-words [ dup word-name "foo" get set-splay ] each
+all-words [ word-name "foo" get get-splay drop ] each
: join ( chan -- )
"JOIN " irc-write irc-print ;
-GENERIC: handle-irc
+GENERIC: handle-irc ( line -- )
PREDICATE: string privmsg " " split1 nip "PRIVMSG" head? ;
PREDICATE: string ping "PING" head? ;
drop speaker get "slava" = [ disconnect ] when ;
PROVIDE: examples/factorbot ;
+
+MAIN: examples/factorbot factorbot ;
: lcd ( digit-str -- )
3 [ 2dup lcd-row terpri ] repeat drop ;
-"31337" lcd
-
PROVIDE: examples/lcd ;
+
+MAIN: examples/lcd "31337" lcd ;
+++ /dev/null
-! Copyright (C) 2006 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays compiler help io kernel math namespaces sequences
-test words ;
-IN: levenshtein
-
-: <matrix> ( m n -- matrix )
- [ drop 0 <array> ] map-with ; inline
-
-: matrix-> nth nth ; inline
-: ->matrix nth set-nth ; inline
-
-SYMBOL: d
-
-: ->d ( n i j -- ) d get ->matrix ; inline
-: d-> ( i j -- n ) d get matrix-> ; inline
-
-SYMBOL: costs
-
-: init-d ( str1 str2 -- )
- [ length 1+ ] 2apply 2dup <matrix> d set
- [ 0 over ->d ] each
- [ dup 0 ->d ] each ; inline
-
-: compute-costs ( str1 str2 -- )
- >array [
- swap >array [ = 0 1 ? ] map-with
- ] map-with costs set ; inline
-
-: levenshtein-step ( i j -- )
- [ 1+ d-> 1+ ] 2keep
- [ >r 1+ r> d-> 1+ ] 2keep
- [ d-> ] 2keep
- [ costs get matrix-> + min min ] 2keep
- >r 1+ r> 1+ ->d ; inline
-
-: levenshtein-result ( -- n ) d get peek peek ; inline
-
-: levenshtein ( str1 str2 -- n )
- [
- 2dup init-d
- 2dup compute-costs
- [ length ] 2apply [
- swap [ swap levenshtein-step ] each-with
- ] each-with
- levenshtein-result
- ] with-scope ; compiled
-
-[ 3 ] [ "sitting" "kitten" levenshtein ] unit-test
-[ 3 ] [ "kitten" "sitting" levenshtein ] unit-test
-[ 1 ] [ "freshpak" "freshpack" levenshtein ] unit-test
-[ 1 ] [ "freshpack" "freshpak" levenshtein ] unit-test
-
-: fancy-apropos ( str -- )
- all-words
- [ [ word-name levenshtein ] keep 2array ] map-with
- [ first 3 <= ] subset
- natural-sort [
- second [ word-name ] keep [ help ] write-outliner
- terpri
- ] each ;
-
-PROVIDE: examples/levenshtein ;
--- /dev/null
+! Copyright (C) 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays help io kernel math namespaces sequences words ;
+IN: levenshtein
+
+: <matrix> ( m n -- matrix )
+ [ drop 0 <array> ] map-with ; inline
+
+: matrix-> nth nth ; inline
+: ->matrix nth set-nth ; inline
+
+SYMBOL: d
+
+: ->d ( n i j -- ) d get ->matrix ; inline
+: d-> ( i j -- n ) d get matrix-> ; inline
+
+SYMBOL: costs
+
+: init-d ( str1 str2 -- )
+ [ length 1+ ] 2apply 2dup <matrix> d set
+ [ 0 over ->d ] each
+ [ dup 0 ->d ] each ; inline
+
+: compute-costs ( str1 str2 -- )
+ >array [
+ swap >array [ = 0 1 ? ] map-with
+ ] map-with costs set ; inline
+
+: levenshtein-step ( i j -- )
+ [ 1+ d-> 1+ ] 2keep
+ [ >r 1+ r> d-> 1+ ] 2keep
+ [ d-> ] 2keep
+ [ costs get matrix-> + min min ] 2keep
+ >r 1+ r> 1+ ->d ; inline
+
+: levenshtein-result ( -- n ) d get peek peek ; inline
+
+: levenshtein ( str1 str2 -- n )
+ [
+ 2dup init-d
+ 2dup compute-costs
+ [ length ] 2apply [
+ swap [ swap levenshtein-step ] each-with
+ ] each-with
+ levenshtein-result
+ ] with-scope ;
+
+: fancy-apropos ( str -- )
+ all-words
+ [ [ word-name levenshtein ] keep 2array ] map-with
+ [ first 3 <= ] subset
+ natural-sort [
+ second [ word-name ] keep [ help ] write-outliner
+ terpri
+ ] each ;
--- /dev/null
+PROVIDE: examples/levenshtein
+{ +files+ { "levenshtein.factor" } }
+{ +tests+ { "tests.factor" } } ;
--- /dev/null
+! Copyright (C) 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: levenshtein
+USING: test ;
+
+[ 3 ] [ "sitting" "kitten" levenshtein ] unit-test
+[ 3 ] [ "kitten" "sitting" levenshtein ] unit-test
+[ 1 ] [ "freshpak" "freshpack" levenshtein ] unit-test
+[ 1 ] [ "freshpack" "freshpak" levenshtein ] unit-test
+++ /dev/null
-! Run this file to write a Mandelbrot fractal to "mandel.ppm".
-
-IN: mandel
-USING: arrays compiler io kernel math namespaces sequences
-strings test ;
-
-: max-color 360 ; inline
-: zoom-fact 0.8 ; inline
-: width 640 ; inline
-: height 480 ; inline
-: nb-iter 40 ; inline
-: center -0.65 ; inline
-
-: f_ ( h s v i -- f ) >r swap rot >r 2dup r> 6 * r> - ;
-: p ( v s x -- v p x ) >r dupd neg 1 + * r> ;
-: q ( v s f -- q ) * neg 1 + * ;
-: t_ ( v s f -- t_ ) neg 1 + * neg 1 + * ;
-
-: mod-cond ( p vector -- )
- #! Call p mod q'th entry of the vector of quotations, where
- #! q is the length of the vector. The value q remains on the
- #! stack.
- [ dupd length mod ] keep nth call ;
-
-: hsv>rgb ( h s v -- r g b )
- pick 6 * >fixnum {
- [ f_ t_ p swap ( v p t ) ]
- [ f_ q p -rot ( q v p ) ]
- [ f_ t_ p swapd ( p v t ) ]
- [ f_ q p rot ( p q v ) ]
- [ f_ t_ p swap rot ( t p v ) ]
- [ f_ q p ( v p q ) ]
- } mod-cond ;
-
-[ 1/2 1/2 1/2 ] [ 0 0 1/2 hsv>rgb ] unit-test
-
-[ 1/2 1/4 1/4 ] [ 0 1/2 1/2 hsv>rgb ] unit-test
-[ 1/3 2/9 2/9 ] [ 0 1/3 1/3 hsv>rgb ] unit-test
-
-[ 24/125 1/5 4/25 ] [ 1/5 1/5 1/5 hsv>rgb ] unit-test
-[ 29/180 1/6 5/36 ] [ 1/5 1/6 1/6 hsv>rgb ] unit-test
-
-[ 6/25 2/5 38/125 ] [ 2/5 2/5 2/5 hsv>rgb ] unit-test
-[ 8/25 4/5 64/125 ] [ 2/5 3/5 4/5 hsv>rgb ] unit-test
-
-[ 6/25 48/125 3/5 ] [ 3/5 3/5 3/5 hsv>rgb ] unit-test
-[ 0 0 0 ] [ 3/5 1/5 0 hsv>rgb ] unit-test
-
-[ 84/125 4/25 4/5 ] [ 4/5 4/5 4/5 hsv>rgb ] unit-test
-[ 7/15 1/3 1/2 ] [ 4/5 1/3 1/2 hsv>rgb ] unit-test
-
-[ 5/6 5/36 5/6 ] [ 5/6 5/6 5/6 hsv>rgb ] unit-test
-[ 1/6 0 1/6 ] [ 5/6 1 1/6 hsv>rgb ] unit-test
-
-[ 1 0 0 ] [ 1 1 1 hsv>rgb ] unit-test
-[ 1/6 1/9 1/9 ] [ 1 1/3 1/6 hsv>rgb ] unit-test
-
-: scale 255 * >fixnum ; inline
-
-: scale-rgb ( r g b -- n )
- rot scale rot scale rot scale 3array ;
-
-: sat 0.85 ; inline
-: val 0.85 ; inline
-
-: <color-map> ( nb-cols -- map )
- dup [
- 360 * swap 1+ / 360 / sat val
- hsv>rgb scale-rgb
- ] map-with ;
-
-: iter ( c z nb-iter -- x )
- over absq 4.0 >= over zero? or
- [ 2nip ] [ 1- >r sq dupd + r> iter ] if ; inline
-
-SYMBOL: cols
-
-: x-inc width 200000 zoom-fact * / ; inline
-: y-inc height 150000 zoom-fact * / ; inline
-
-: c ( i j -- c )
- >r
- x-inc * center real x-inc width 2 / * - + >float
- r>
- y-inc * center imaginary y-inc height 2 / * - + >float
- rect> ; inline
-
-: render ( -- )
- height [
- width [
- 2dup swap c 0 nb-iter iter dup zero? [
- drop "\0\0\0"
- ] [
- cols get [ length mod ] keep nth
- ] if %
- ] repeat
- ] repeat ;
-
-: ppm-header ( w h -- )
- "P6\n" % swap # " " % # "\n255\n" % ;
-
-: sbuf-size width height * 3 * 100 + ;
-
-: run ( -- string )
- [
- sbuf-size <sbuf> building set
- width height ppm-header
- nb-iter max-color min <color-map> cols set
- render
- building get >string
- ] with-scope ;
-
-: run>file ( file -- )
- "Generating " write dup write "..." print
- <file-writer> [ run write ] with-stream ;
-
-[ "mandel.pnm" run>file ] time
-
-PROVIDE: examples/mandel ;
--- /dev/null
+PROVIDE: examples/mandel
+{ +files+ { "mandel.factor" } }
+{ +tests+ { "tests.factor" } } ;
+
+USE: mandel
+USE: test
+
+MAIN: examples/mandel [ "mandel.pnm" run>file ] time ;
--- /dev/null
+! Run this file to write a Mandelbrot fractal to "mandel.ppm".
+
+IN: mandel
+USING: arrays compiler io kernel math namespaces sequences
+strings test ;
+
+: max-color 360 ; inline
+: zoom-fact 0.8 ; inline
+: width 640 ; inline
+: height 480 ; inline
+: nb-iter 40 ; inline
+: center -0.65 ; inline
+
+: f_ >r swap rot >r 2dup r> 6 * r> - ;
+: p ( v s x -- v p x ) >r dupd neg 1 + * r> ;
+: q ( v s f -- q ) * neg 1 + * ;
+: t_ ( v s f -- t_ ) neg 1 + * neg 1 + * ;
+
+: mod-cond ( p vector -- )
+ #! Call p mod q'th entry of the vector of quotations, where
+ #! q is the length of the vector. The value q remains on the
+ #! stack.
+ [ dupd length mod ] keep nth call ;
+
+: hsv>rgb ( h s v -- r g b )
+ pick 6 * >fixnum {
+ [ f_ t_ p swap ] ! v p t
+ [ f_ q p -rot ] ! q v p
+ [ f_ t_ p swapd ] ! p v t
+ [ f_ q p rot ] ! p q v
+ [ f_ t_ p swap rot ] ! t p v
+ [ f_ q p ] ! v p q
+ } mod-cond ;
+
+: scale 255 * >fixnum ; inline
+
+: scale-rgb ( r g b -- n )
+ rot scale rot scale rot scale 3array ;
+
+: sat 0.85 ; inline
+: val 0.85 ; inline
+
+: <color-map> ( nb-cols -- map )
+ dup [
+ 360 * swap 1+ / 360 / sat val
+ hsv>rgb scale-rgb
+ ] map-with ;
+
+: iter ( c z nb-iter -- x )
+ over absq 4.0 >= over zero? or
+ [ 2nip ] [ 1- >r sq dupd + r> iter ] if ; inline
+
+SYMBOL: cols
+
+: x-inc width 200000 zoom-fact * / ; inline
+: y-inc height 150000 zoom-fact * / ; inline
+
+: c ( i j -- c )
+ >r
+ x-inc * center real x-inc width 2 / * - + >float
+ r>
+ y-inc * center imaginary y-inc height 2 / * - + >float
+ rect> ; inline
+
+: render ( -- )
+ height [
+ width [
+ 2dup swap c 0 nb-iter iter dup zero? [
+ drop "\0\0\0"
+ ] [
+ cols get [ length mod ] keep nth
+ ] if %
+ ] repeat
+ ] repeat ;
+
+: ppm-header ( w h -- )
+ "P6\n" % swap # " " % # "\n255\n" % ;
+
+: sbuf-size width height * 3 * 100 + ;
+
+: run ( -- string )
+ [
+ sbuf-size <sbuf> building set
+ width height ppm-header
+ nb-iter max-color min <color-map> cols set
+ render
+ building get >string
+ ] with-scope ;
+
+: run>file ( file -- )
+ "Generating " write dup write "..." print
+ <file-writer> [ run write ] with-stream ;
--- /dev/null
+IN: mandel
+USE: test
+
+[ 1/2 1/2 1/2 ] [ 0 0 1/2 hsv>rgb ] unit-test
+
+[ 1/2 1/4 1/4 ] [ 0 1/2 1/2 hsv>rgb ] unit-test
+[ 1/3 2/9 2/9 ] [ 0 1/3 1/3 hsv>rgb ] unit-test
+
+[ 24/125 1/5 4/25 ] [ 1/5 1/5 1/5 hsv>rgb ] unit-test
+[ 29/180 1/6 5/36 ] [ 1/5 1/6 1/6 hsv>rgb ] unit-test
+
+[ 6/25 2/5 38/125 ] [ 2/5 2/5 2/5 hsv>rgb ] unit-test
+[ 8/25 4/5 64/125 ] [ 2/5 3/5 4/5 hsv>rgb ] unit-test
+
+[ 6/25 48/125 3/5 ] [ 3/5 3/5 3/5 hsv>rgb ] unit-test
+[ 0 0 0 ] [ 3/5 1/5 0 hsv>rgb ] unit-test
+
+[ 84/125 4/25 4/5 ] [ 4/5 4/5 4/5 hsv>rgb ] unit-test
+[ 7/15 1/3 1/2 ] [ 4/5 1/3 1/2 hsv>rgb ] unit-test
+
+[ 5/6 5/36 5/6 ] [ 5/6 5/6 5/6 hsv>rgb ] unit-test
+[ 1/6 0 1/6 ] [ 5/6 1 1/6 hsv>rgb ] unit-test
+
+[ 1 0 0 ] [ 1 1 1 hsv>rgb ] unit-test
+[ 1/6 1/9 1/9 ] [ 1 1/3 1/6 hsv>rgb ] unit-test
+++ /dev/null
-IN: print-dataflow
-USING: generic hashtables inference io kernel kernel-internals
-math namespaces prettyprint sequences styles vectors words
-test optimizer ;
-
-! A simple tool for turning dataflow IR into quotations, for
-! debugging purposes.
-
-GENERIC: node>quot ( ? node -- )
-
-TUPLE: comment node text ;
-
-M: comment pprint*
- "( " over comment-text " )" append3
- swap comment-node presented associate
- styled-text ;
-
-: comment, ( ? node text -- )
- rot [ <comment> , ] [ 2drop ] if ;
-
-: values% ( prefix values -- )
- [
- swap %
- dup value? [
- value-literal unparse %
- ] [
- "@" % #
- ] if
- ] each-with ;
-
-: effect-str ( node -- str )
- [
- " " over node-in-d values%
- " r: " over node-in-r values%
- " --" %
- " " over node-out-d values%
- " r: " swap node-out-r values%
- ] "" make 1 tail ;
-
-M: #shuffle node>quot
- >r drop t r> dup effect-str "#shuffle: " swap append comment, ;
-
-M: #push node>quot nip >#push< % ;
-
-DEFER: dataflow>quot
-
-: #call>quot ( ? node -- )
- dup node-param dup
- [ , dup effect-str comment, ] [ 3drop ] if ;
-
-M: #call node>quot #call>quot ;
-
-M: #call-label node>quot #call>quot ;
-
-M: #label node>quot
- [ "#label: " over node-param word-name append comment, ] 2keep
- node-child swap dataflow>quot , \ call , ;
-
-M: #if node>quot
- [ "#if" comment, ] 2keep
- node-children [ swap dataflow>quot ] map-with % \ if , ;
-
-M: #dispatch node>quot
- [ "#dispatch" comment, ] 2keep
- node-children [ swap dataflow>quot ] map-with , \ dispatch , ;
-
-M: #return node>quot
- dup node-param unparse "#return " swap append comment, ;
-
-M: object node>quot dup class word-name comment, ;
-
-: (dataflow>quot) ( ? node -- )
- dup [
- 2dup node>quot node-successor (dataflow>quot)
- ] [
- 2drop
- ] if ;
-
-: dataflow>quot ( node ? -- quot )
- [ swap (dataflow>quot) ] [ ] make ;
-
-: dataflow. ( quot ? -- )
- #! Print dataflow IR for a quotation. Flag indicates if
- #! annotations should be printed or not.
- >r dataflow optimize r> dataflow>quot . ;
-
-[ ] [ [ 2 ] t dataflow. ] unit-test
-[ ] [ [ 3 + ] t dataflow. ] unit-test
-[ ] [ [ drop ] t dataflow. ] unit-test
-[ ] [ [ [ sq ] [ abs ] if ] t dataflow. ] unit-test
-[ ] [ [ { [ sq ] [ abs ] } dispatch ] t dataflow. ] unit-test
-[ ] [ \ unify-values word-def t dataflow. ] unit-test
-[ ] [ [ 0 0 / ] t dataflow. ] unit-test
--- /dev/null
+PROVIDE: examples/print-dataflow
+{ +files+ { "print-dataflow.factor" } }
+{ +tests+ { "tests.factor" } } ;
--- /dev/null
+IN: print-dataflow
+USING: generic hashtables inference io kernel kernel-internals
+math namespaces prettyprint sequences styles vectors words
+optimizer ;
+
+! A simple tool for turning dataflow IR into quotations, for
+! debugging purposes.
+
+GENERIC: node>quot ( ? node -- )
+
+TUPLE: comment node text ;
+
+M: comment pprint*
+ "( " over comment-text " )" append3
+ swap comment-node presented associate
+ styled-text ;
+
+: comment, ( ? node text -- )
+ rot [ <comment> , ] [ 2drop ] if ;
+
+: values% ( prefix values -- )
+ [
+ swap %
+ dup value? [
+ value-literal unparse %
+ ] [
+ "@" % #
+ ] if
+ ] each-with ;
+
+: effect-str ( node -- str )
+ [
+ " " over node-in-d values%
+ " r: " over node-in-r values%
+ " --" %
+ " " over node-out-d values%
+ " r: " swap node-out-r values%
+ ] "" make 1 tail ;
+
+M: #shuffle node>quot
+ >r drop t r> dup effect-str "#shuffle: " swap append comment, ;
+
+M: #push node>quot nip >#push< % ;
+
+DEFER: dataflow>quot
+
+: #call>quot ( ? node -- )
+ dup node-param dup
+ [ , dup effect-str comment, ] [ 3drop ] if ;
+
+M: #call node>quot #call>quot ;
+
+M: #call-label node>quot #call>quot ;
+
+M: #label node>quot
+ [ "#label: " over node-param word-name append comment, ] 2keep
+ node-child swap dataflow>quot , \ call , ;
+
+M: #if node>quot
+ [ "#if" comment, ] 2keep
+ node-children [ swap dataflow>quot ] map-with % \ if , ;
+
+M: #dispatch node>quot
+ [ "#dispatch" comment, ] 2keep
+ node-children [ swap dataflow>quot ] map-with , \ dispatch , ;
+
+M: #return node>quot
+ dup node-param unparse "#return " swap append comment, ;
+
+M: object node>quot dup class word-name comment, ;
+
+: (dataflow>quot) ( ? node -- )
+ dup [
+ 2dup node>quot node-successor (dataflow>quot)
+ ] [
+ 2drop
+ ] if ;
+
+: dataflow>quot ( node ? -- quot )
+ [ swap (dataflow>quot) ] [ ] make ;
+
+: dataflow. ( quot ? -- )
+ #! Print dataflow IR for a quotation. Flag indicates if
+ #! annotations should be printed or not.
+ >r dataflow optimize r> dataflow>quot . ;
--- /dev/null
+IN: print-dataflow
+
+[ ] [ [ 2 ] t dataflow. ] unit-test
+[ ] [ [ 3 + ] t dataflow. ] unit-test
+[ ] [ [ drop ] t dataflow. ] unit-test
+[ ] [ [ [ sq ] [ abs ] if ] t dataflow. ] unit-test
+[ ] [ [ { [ sq ] [ abs ] } dispatch ] t dataflow. ] unit-test
+[ ] [ \ unify-values word-def t dataflow. ] unit-test
+[ ] [ [ 0 0 / ] t dataflow. ] unit-test
"Generating " write dup write "..." print
<file-writer> [ run write ] with-stream ;
-[ "raytracer.pnm" run>file ] time
-
PROVIDE: examples/raytracer ;
+
+MAIN: examples/raytracer [ "raytracer.pnm" run>file ] time ;
IN: turing
-USING: arrays hashtables io kernel lists math namespaces
+USING: arrays hashtables io kernel math namespaces
prettyprint sequences strings vectors words ;
! A turing machine simulator.
! This is a simple program that outputs 5 1's
H{
- { [[ 1 0 ]] T{ state f 1 1 2 } }
- { [[ 2 0 ]] T{ state f 1 1 3 } }
- { [[ 3 0 ]] T{ state f 1 -1 1 } }
- { [[ 1 1 ]] T{ state f 1 -1 2 } }
- { [[ 2 1 ]] T{ state f 1 -1 3 } }
- { [[ 3 1 ]] T{ state f 1 -1 halt } }
+ { { 1 0 } T{ state f 1 1 2 } }
+ { { 2 0 } T{ state f 1 1 3 } }
+ { { 3 0 } T{ state f 1 -1 1 } }
+ { { 1 1 } T{ state f 1 -1 2 } }
+ { { 2 1 } T{ state f 1 -1 3 } }
+ { { 3 1 } T{ state f 1 -1 halt } }
} states set
! Current state
: next-state ( -- state )
#! Look up the next state/symbol/direction triplet.
- state get sym cons states get hash ;
+ state get sym 2array states get hash ;
: turing-step ( -- )
#! Do one step of the turing machine.
#! Print current turing machine state.
state get .
tape get .
- 2 position get 2 * + CHAR: \s fill write "^" print ;
+ 2 position get 2 * + CHAR: \s <string> write "^" print ;
: n
#! Do one step and print new state.
] when ;
: undo-infer ( -- )
- recorded get [ "infer" word-prop not ] subset [
+ recorded get [ custom-infer? not ] subset [
dup
f "inferred-vars" set-word-prop
f "inferred-effect" set-word-prop
[ swap call dup rot fuzzy score ] keep swap 2array
] if ; inline
-: completions ( str candidates quot -- seq )
- pick empty? pick length 100 >= and [
+: completions ( str quot candidates -- seq )
+ pick empty? over length 100 >= and [
3drop f
] [
[ >r 2dup r> completion ] map 2nip rank-completions
: reset-props ( word seq -- ) [ remove-word-prop ] each-with ;
+: custom-infer? ( word -- ? )
+ dup "infer" word-prop swap "infer-vars" word-prop or ;
+
: unxref-word* ( word -- )
{
{ [ dup compound? not ] [ drop ] }
- { [ dup "infer" word-prop ] [ drop ] }
+ { [ dup custom-infer? ] [ drop ] }
{ [ t ] [
dup changed-word
{
projects / factor.git / commitdiff