From b2f4217e082eaddbec37f410e23d9d34416dfb97 Mon Sep 17 00:00:00 2001 From: James Cash Date: Mon, 26 May 2008 21:22:39 -0400 Subject: [PATCH 01/71] Making indentation default 4 spaces, instead of 2 --- misc/factor.el | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/misc/factor.el b/misc/factor.el index 9d90fb68f9..300c95c430 100644 --- a/misc/factor.el +++ b/misc/factor.el @@ -94,6 +94,10 @@ "SYMBOLS:" )) +(defun factor-indent-line () + "Indent current line as Factor code" + (indent-line-to (+ (current-indentation) 4))) + (defun factor-mode () "A mode for editing programs written in the Factor programming language." (interactive) @@ -107,6 +111,8 @@ (setq font-lock-defaults '(factor-font-lock-keywords nil nil nil nil)) (set-syntax-table factor-mode-syntax-table) + (make-local-variable 'indent-line-function) + (setq indent-line-function 'factor-indent-line) (run-hooks 'factor-mode-hook)) (add-to-list 'auto-mode-alist '("\\.factor\\'" . factor-mode)) From 4171f445a83dfabe893085bc85cc14a8f67e00fe Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Thu, 29 May 2008 14:14:18 +1000 Subject: [PATCH 02/71] new jamshred collision model almost working (but buggy as hell) --- extra/jamshred/gl/gl.factor | 33 +++++++- extra/jamshred/oint/oint.factor | 11 ++- extra/jamshred/player/player.factor | 95 ++++++++++++++++------- extra/jamshred/tunnel/tunnel-tests.factor | 2 +- extra/jamshred/tunnel/tunnel.factor | 79 +++++++++---------- 5 files changed, 148 insertions(+), 72 deletions(-) diff --git a/extra/jamshred/gl/gl.factor b/extra/jamshred/gl/gl.factor index fffc97b4c6..4171c79a0a 100644 --- a/extra/jamshred/gl/gl.factor +++ b/extra/jamshred/gl/gl.factor @@ -1,8 +1,6 @@ ! Copyright (C) 2007 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien.c-types colors jamshred.game jamshred.oint -jamshred.player jamshred.tunnel kernel math math.vectors opengl -opengl.gl opengl.glu sequences ; +USING: accessors alien.c-types colors jamshred.game jamshred.oint jamshred.player jamshred.tunnel kernel math math.constants math.functions math.vectors opengl opengl.gl opengl.glu sequences ; IN: jamshred.gl : min-vertices 6 ; inline @@ -14,6 +12,35 @@ IN: jamshred.gl : n-segments-ahead ( -- n ) 60 ; inline : n-segments-behind ( -- n ) 40 ; inline +: wall-drawing-offset ( -- n ) + #! so that we can't see through the wall, we draw it a bit further away + 0.15 ; + +: wall-drawing-radius ( segment -- r ) + radius>> wall-drawing-offset + ; + +: wall-up ( segment -- v ) + [ wall-drawing-radius ] [ up>> ] bi n*v ; + +: wall-left ( segment -- v ) + [ wall-drawing-radius ] [ left>> ] bi n*v ; + +: segment-vertex ( theta segment -- vertex ) + [ + [ wall-up swap sin v*n ] [ wall-left swap cos v*n ] 2bi v+ + ] [ + location>> v+ + ] bi ; + +: segment-vertex-normal ( vertex segment -- normal ) + location>> swap v- normalize ; + +: segment-vertex-and-normal ( segment theta -- vertex normal ) + swap [ segment-vertex ] keep dupd segment-vertex-normal ; + +: equally-spaced-radians ( n -- seq ) + #! return a sequence of n numbers between 0 and 2pi + dup [ / pi 2 * * ] curry map ; : draw-segment-vertex ( segment theta -- ) over segment-color gl-color segment-vertex-and-normal gl-normal gl-vertex ; diff --git a/extra/jamshred/oint/oint.factor b/extra/jamshred/oint/oint.factor index d50a93a3d2..7a37646a6d 100644 --- a/extra/jamshred/oint/oint.factor +++ b/extra/jamshred/oint/oint.factor @@ -39,8 +39,11 @@ C: oint : random-turn ( oint theta -- ) 2 / 2dup random-float+- left-pivot random-float+- up-pivot ; +: location+ ( v oint -- ) + [ location>> v+ ] [ (>>location) ] bi ; + : go-forward ( distance oint -- ) - [ forward>> n*v ] [ location>> v+ ] [ (>>location) ] tri ; + [ forward>> n*v ] [ location+ ] bi ; : distance-vector ( oint oint -- vector ) [ location>> ] bi@ swap v- ; @@ -62,3 +65,9 @@ C: oint :: reflect ( v n -- v' ) #! bounce v on a surface with normal n v v n v. n n v. / 2 * n n*v v- ; + +: half-way ( p1 p2 -- p3 ) + over v- 2 v/n v+ ; + +: half-way-between-oints ( o1 o2 -- p ) + [ location>> ] bi@ half-way ; diff --git a/extra/jamshred/player/player.factor b/extra/jamshred/player/player.factor index 8dc5125143..ccef69a6e4 100644 --- a/extra/jamshred/player/player.factor +++ b/extra/jamshred/player/player.factor @@ -1,6 +1,7 @@ -! Copyright (C) 2007 Alex Chapman +! Copyright (C) 2007, 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors colors combinators jamshred.log jamshred.oint jamshred.sound jamshred.tunnel kernel math math.constants math.order math.ranges shuffle sequences system ; +USING: accessors colors combinators jamshred.log jamshred.oint jamshred.sound jamshred.tunnel kernel locals math math.constants math.order math.ranges math.vectors math.matrices shuffle sequences system ; +USE: tools.walker IN: jamshred.player TUPLE: player < oint name sounds tunnel nearest-segment last-move speed ; @@ -30,6 +31,9 @@ TUPLE: player < oint name sounds tunnel nearest-segment last-move speed ; [ tunnel>> ] [ dup nearest-segment>> nearest-segment ] [ (>>nearest-segment) ] tri ; +: update-time ( player -- seconds-passed ) + millis swap [ last-move>> - 1000 / ] [ (>>last-move) ] 2bi ; + : moved ( player -- ) millis swap (>>last-move) ; : speed-range ( -- range ) @@ -41,38 +45,73 @@ TUPLE: player < oint name sounds tunnel nearest-segment last-move speed ; : multiply-player-speed ( n player -- ) [ * speed-range clamp-to-range ] change-speed drop ; -: distance-to-move ( player -- distance ) - [ speed>> ] [ last-move>> millis dup >r swap - 1000 / * r> ] - [ (>>last-move) ] tri ; +: distance-to-move ( seconds-passed player -- distance ) + speed>> * ; -DEFER: (move-player) +: bounce ( d-left player -- d-left' player ) + { + [ dup nearest-segment>> bounce-off-wall ] + [ sounds>> bang ] + [ 3/4 swap multiply-player-speed ] + [ ] + } cleave ; -: ?bounce ( distance-remaining player -- ) +:: move-player-on-heading ( d-left player distance heading -- d-left' player ) + [let* | d-to-move [ d-left distance min ] + move-v [ d-to-move heading n*v ] | + move-v player location+ + player update-nearest-segment + d-left d-to-move - player ] ; + +: (distance) ( player -- segments current location ) + [ tunnel>> ] [ nearest-segment>> ] [ location>> ] tri ; + +: distance-to-next-segment ( player -- distance ) + [ (distance) ] [ forward>> distance-to-heading-segment ] bi ; + +: distance-to-collision ( player -- distance ) + dup nearest-segment>> (distance-to-collision) ; + +: move-toward-wall ( d-left player d-to-wall -- d-left' player ) + over distance-to-next-segment min + over forward>> move-player-on-heading ; + +: from ( player -- radius distance-from-centre ) + [ nearest-segment>> dup radius>> swap ] [ location>> ] bi + distance-from-centre ; + +: distance-from-wall ( player -- distance ) from - ; +: fraction-from-centre ( player -- fraction ) from swap / ; +: fraction-from-wall ( player -- fraction ) + fraction-from-centre 1 swap - ; + +: ?move-player-freely ( d-left player -- d-left' player ) + ! 2dup [ 0 > ] [ fraction-from-wall 0 > ] bi* and [ over 0 > [ - { - [ dup nearest-segment>> bounce ] - [ sounds>> bang ] - [ 3/4 swap multiply-player-speed ] - [ (move-player) ] - } cleave - ] [ - 2drop - ] if ; + dup distance-to-collision dup 0 > [ + move-toward-wall ?move-player-freely + ] [ drop ] if + ] when ; -: move-player-distance ( distance-remaining player distance -- distance-remaining player ) - pick min tuck over go-forward [ - ] dip ; +: drag-heading ( player -- heading ) + [ forward>> ] [ nearest-segment>> forward>> proj ] bi ; -: (move-player) ( distance-remaining player -- ) - over 0 <= [ - 2drop - ] [ - dup dup nearest-segment>> distance-to-collision - move-player-distance ?bounce - ] if ; +: drag-distance-to-next-segment ( player -- distance ) + [ (distance) ] [ drag-heading distance-to-heading-segment ] bi ; + +: drag-player ( d-left player -- d-left' player ) + dup [ drag-distance-to-next-segment ] + [ drag-heading move-player-on-heading ] bi ; + +: (move-player) ( d-left player -- d-left' player ) + ?move-player-freely over 0 > [ + ! bounce + drag-player + ! (move-player) + ] when ; : move-player ( player -- ) - [ distance-to-move ] [ (move-player) ] [ update-nearest-segment ] tri ; + [ update-time ] [ distance-to-move ] [ (move-player) 2drop ] tri ; : update-player ( player -- ) - dup move-player nearest-segment>> - white swap set-segment-color ; + [ move-player ] [ nearest-segment>> white swap (>>color) ] bi ; diff --git a/extra/jamshred/tunnel/tunnel-tests.factor b/extra/jamshred/tunnel/tunnel-tests.factor index 903ff94739..722609851a 100644 --- a/extra/jamshred/tunnel/tunnel-tests.factor +++ b/extra/jamshred/tunnel/tunnel-tests.factor @@ -42,4 +42,4 @@ IN: jamshred.tunnel.tests [ { 0 1 0 } ] [ simple-collision-up sideways-heading ] unit-test [ { 0 0 0 } ] [ simple-collision-up sideways-relative-location ] unit-test [ { 0 1 0 } ] -[ simple-collision-up collision-vector 0 bounce-offset 0 3array v+ ] unit-test +[ simple-collision-up collision-vector 0 0 0 3array v+ ] unit-test diff --git a/extra/jamshred/tunnel/tunnel.factor b/extra/jamshred/tunnel/tunnel.factor index 5cf1e33e64..24b4b6a386 100755 --- a/extra/jamshred/tunnel/tunnel.factor +++ b/extra/jamshred/tunnel/tunnel.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2007 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays combinators float-arrays kernel jamshred.oint locals math math.functions math.constants math.matrices math.order math.ranges math.vectors math.quadratic random sequences vectors ; +USING: accessors arrays combinators float-arrays kernel jamshred.oint locals math math.constants math.matrices math.order math.ranges math.vectors math.quadratic random sequences vectors ; +USE: tools.walker IN: jamshred.tunnel : n-segments ( -- n ) 5000 ; inline @@ -8,21 +9,6 @@ IN: jamshred.tunnel TUPLE: segment < oint number color radius ; C: segment -: segment-vertex ( theta segment -- vertex ) - tuck 2dup up>> swap sin v*n - >r left>> swap cos v*n r> v+ - swap location>> v+ ; - -: segment-vertex-normal ( vertex segment -- normal ) - location>> swap v- normalize ; - -: segment-vertex-and-normal ( segment theta -- vertex normal ) - swap [ segment-vertex ] keep dupd segment-vertex-normal ; - -: equally-spaced-radians ( n -- seq ) - #! return a sequence of n numbers between 0 and 2pi - dup [ / pi 2 * * ] curry map ; - : segment-number++ ( segment -- ) [ number>> 1+ ] keep (>>number) ; @@ -40,9 +26,7 @@ C: segment : (random-segments) ( segments n -- segments ) dup 0 > [ >r dup peek random-segment over push r> 1- (random-segments) - ] [ - drop - ] if ; + ] [ drop ] if ; : default-segment-radius ( -- r ) 1 ; @@ -66,7 +50,7 @@ C: segment : ( -- segments ) n-segments simple-segments ; -: sub-tunnel ( from to sements -- segments ) +: sub-tunnel ( from to segments -- segments ) #! return segments between from and to, after clamping from and to to #! valid values [ sequence-index-range [ clamp-to-range ] curry bi@ ] keep ; @@ -97,6 +81,30 @@ C: segment [ nearest-segment-forward ] 3keep nearest-segment-backward r> nearer-segment ; +: get-segment ( segments n -- segment ) + over sequence-index-range clamp-to-range swap nth ; + +: next-segment ( segments current-segment -- segment ) + number>> 1+ get-segment ; + +: previous-segment ( segments current-segment -- segment ) + number>> 1- get-segment ; + +: heading-segment ( segments current-segment heading -- segment ) + #! the next segment on the given heading + over forward>> v. 0 <=> { + { +gt+ [ next-segment ] } + { +lt+ [ previous-segment ] } + { +eq+ [ nip ] } ! current segment + } case ; + +:: distance-to-heading-segment ( segments current location heading -- distance ) + #! the distance on the oint's current heading until it enters the next + #! segment's cross-section + [let* | next [ segments current heading heading-segment location>> ] + cf [ current forward>> ] | + cf next v. cf location v. - cf heading v. / ] ; + : vector-to-centre ( seg loc -- v ) over location>> swap v- swap forward>> proj-perp ; @@ -106,19 +114,17 @@ C: segment : wall-normal ( seg oint -- n ) location>> vector-to-centre normalize ; -: from ( seg loc -- radius d-f-c ) - dupd location>> distance-from-centre [ radius>> ] dip ; - -: distance-from-wall ( seg loc -- distance ) from - ; -: fraction-from-centre ( seg loc -- fraction ) from / ; -: fraction-from-wall ( seg loc -- fraction ) - fraction-from-centre 1 swap - ; +: distant ( -- n ) 1000 ; :: collision-coefficient ( v w r -- c ) - [let* | a [ v dup v. ] - b [ v w v. 2 * ] - c [ w dup v. r sq - ] | - c b a quadratic max ] ; + v norm 0 = [ + distant + ] [ + [let* | a [ v dup v. ] + b [ v w v. 2 * ] + c [ w dup v. r sq - ] | + c b a quadratic max ] + ] if ; : sideways-heading ( oint segment -- v ) [ forward>> ] bi@ proj-perp ; @@ -126,17 +132,12 @@ C: segment : sideways-relative-location ( oint segment -- loc ) [ [ location>> ] bi@ v- ] keep forward>> proj-perp ; -: bounce-offset 0.1 ; inline - -: bounce-radius ( segment -- r ) - radius>> bounce-offset - ; ! bounce before we hit so that we can't see through the wall (hack?) - : collision-vector ( oint segment -- v ) [ sideways-heading ] [ sideways-relative-location ] - [ bounce-radius ] 2tri + [ radius>> ] 2tri swap [ collision-coefficient ] dip forward>> n*v ; -: distance-to-collision ( oint segment -- distance ) +: (distance-to-collision) ( oint segment -- distance ) collision-vector norm ; : bounce-forward ( segment oint -- ) @@ -151,6 +152,6 @@ C: segment #! must be done after forward and left! nip [ forward>> ] [ left>> cross ] [ (>>up) ] tri ; -: bounce ( oint segment -- ) +: bounce-off-wall ( oint segment -- ) swap [ bounce-forward ] [ bounce-left ] [ bounce-up ] 2tri ; From ca8685a2669d1e412e41afbcbc2fea226208aa81 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Fri, 30 May 2008 17:38:48 +1000 Subject: [PATCH 03/71] jamshred still buggy, but player now 'slides' on the walls instead of bouncing --- extra/jamshred/jamshred.factor | 4 +-- extra/jamshred/player/player.factor | 51 +++++++++++++++++------------ extra/jamshred/tunnel/tunnel.factor | 37 +++++++++++++-------- 3 files changed, 55 insertions(+), 37 deletions(-) diff --git a/extra/jamshred/jamshred.factor b/extra/jamshred/jamshred.factor index 078a23f5db..b7764894d1 100755 --- a/extra/jamshred/jamshred.factor +++ b/extra/jamshred/jamshred.factor @@ -88,7 +88,7 @@ jamshred-gadget H{ { T{ mouse-scroll } [ handle-mouse-scroll ] } } set-gestures -: jamshred-window ( -- ) - [ "Jamshred" open-window ] with-ui ; +: jamshred-window ( -- jamshred ) + [ dup "Jamshred" open-window ] with-ui ; MAIN: jamshred-window diff --git a/extra/jamshred/player/player.factor b/extra/jamshred/player/player.factor index ccef69a6e4..c40729e35b 100644 --- a/extra/jamshred/player/player.factor +++ b/extra/jamshred/player/player.factor @@ -56,26 +56,20 @@ TUPLE: player < oint name sounds tunnel nearest-segment last-move speed ; [ ] } cleave ; -:: move-player-on-heading ( d-left player distance heading -- d-left' player ) - [let* | d-to-move [ d-left distance min ] - move-v [ d-to-move heading n*v ] | - move-v player location+ - player update-nearest-segment - d-left d-to-move - player ] ; +:: (distance) ( heading player -- current next location heading ) + player nearest-segment>> + player [ tunnel>> ] [ nearest-segment>> ] bi heading heading-segment + player location>> heading ; -: (distance) ( player -- segments current location ) - [ tunnel>> ] [ nearest-segment>> ] [ location>> ] tri ; +: distance-to-heading-segment ( heading player -- distance ) + (distance) distance-to-next-segment ; -: distance-to-next-segment ( player -- distance ) - [ (distance) ] [ forward>> distance-to-heading-segment ] bi ; +: distance-to-heading-segment-area ( heading player -- distance ) + (distance) distance-to-next-segment-area ; : distance-to-collision ( player -- distance ) dup nearest-segment>> (distance-to-collision) ; -: move-toward-wall ( d-left player d-to-wall -- d-left' player ) - over distance-to-next-segment min - over forward>> move-player-on-heading ; - : from ( player -- radius distance-from-centre ) [ nearest-segment>> dup radius>> swap ] [ location>> ] bi distance-from-centre ; @@ -85,10 +79,28 @@ TUPLE: player < oint name sounds tunnel nearest-segment last-move speed ; : fraction-from-wall ( player -- fraction ) fraction-from-centre 1 swap - ; +: update-nearest-segment2 ( heading player -- ) + 2dup distance-to-heading-segment-area 0 <= [ + [ tunnel>> ] [ nearest-segment>> rot heading-segment ] + [ (>>nearest-segment) ] tri + ] [ + 2drop + ] if ; + +:: move-player-on-heading ( d-left player distance heading -- d-left' player ) + [let* | d-to-move [ d-left distance min ] + move-v [ d-to-move heading n*v ] | + move-v player location+ + heading player update-nearest-segment2 + d-left d-to-move - player ] ; + +: move-toward-wall ( d-left player d-to-wall -- d-left' player ) + over [ forward>> ] keep distance-to-heading-segment-area min + over forward>> move-player-on-heading ; + : ?move-player-freely ( d-left player -- d-left' player ) - ! 2dup [ 0 > ] [ fraction-from-wall 0 > ] bi* and [ over 0 > [ - dup distance-to-collision dup 0 > [ + dup distance-to-collision dup 0.2 > [ ! bug! should be 0, not 0.2 move-toward-wall ?move-player-freely ] [ drop ] if ] when ; @@ -96,18 +108,15 @@ TUPLE: player < oint name sounds tunnel nearest-segment last-move speed ; : drag-heading ( player -- heading ) [ forward>> ] [ nearest-segment>> forward>> proj ] bi ; -: drag-distance-to-next-segment ( player -- distance ) - [ (distance) ] [ drag-heading distance-to-heading-segment ] bi ; - : drag-player ( d-left player -- d-left' player ) - dup [ drag-distance-to-next-segment ] + dup [ [ drag-heading ] keep distance-to-heading-segment-area ] [ drag-heading move-player-on-heading ] bi ; : (move-player) ( d-left player -- d-left' player ) ?move-player-freely over 0 > [ ! bounce drag-player - ! (move-player) + (move-player) ] when ; : move-player ( player -- ) diff --git a/extra/jamshred/tunnel/tunnel.factor b/extra/jamshred/tunnel/tunnel.factor index 24b4b6a386..99c396bebd 100755 --- a/extra/jamshred/tunnel/tunnel.factor +++ b/extra/jamshred/tunnel/tunnel.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2007 Alex Chapman +! Copyright (C) 2007, 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays combinators float-arrays kernel jamshred.oint locals math math.constants math.matrices math.order math.ranges math.vectors math.quadratic random sequences vectors ; USE: tools.walker @@ -98,12 +98,14 @@ C: segment { +eq+ [ nip ] } ! current segment } case ; -:: distance-to-heading-segment ( segments current location heading -- distance ) - #! the distance on the oint's current heading until it enters the next - #! segment's cross-section - [let* | next [ segments current heading heading-segment location>> ] - cf [ current forward>> ] | - cf next v. cf location v. - cf heading v. / ] ; +:: distance-to-next-segment ( current next location heading -- distance ) + [let | cf [ current forward>> ] | + cf next location>> v. cf location v. - cf heading v. / ] ; + +:: distance-to-next-segment-area ( current next location heading -- distance ) + [let | cf [ current forward>> ] + h [ next current half-way-between-oints ] | + cf h v. cf location v. - cf heading v. / ] ; : vector-to-centre ( seg loc -- v ) over location>> swap v- swap forward>> proj-perp ; @@ -116,6 +118,14 @@ C: segment : distant ( -- n ) 1000 ; +: max-real ( a b -- c ) + #! sometimes collision-coefficient yields complex roots, so we ignore these (hack) + dup real? [ + over real? [ max ] [ nip ] if + ] [ + drop dup real? [ drop distant ] unless + ] if ; + :: collision-coefficient ( v w r -- c ) v norm 0 = [ distant @@ -123,7 +133,7 @@ C: segment [let* | a [ v dup v. ] b [ v w v. 2 * ] c [ w dup v. r sq - ] | - c b a quadratic max ] + c b a quadratic max-real ] ] if ; : sideways-heading ( oint segment -- v ) @@ -132,13 +142,12 @@ C: segment : sideways-relative-location ( oint segment -- loc ) [ [ location>> ] bi@ v- ] keep forward>> proj-perp ; -: collision-vector ( oint segment -- v ) - [ sideways-heading ] [ sideways-relative-location ] - [ radius>> ] 2tri - swap [ collision-coefficient ] dip forward>> n*v ; - : (distance-to-collision) ( oint segment -- distance ) - collision-vector norm ; + [ sideways-heading ] [ sideways-relative-location ] + [ nip radius>> ] 2tri collision-coefficient ; + +: collision-vector ( oint segment -- v ) + dupd (distance-to-collision) swap forward>> n*v ; : bounce-forward ( segment oint -- ) [ wall-normal ] [ forward>> swap reflect ] [ (>>forward) ] tri ; From 4b3560d06829c3878287c99735051c9400671fd8 Mon Sep 17 00:00:00 2001 From: James Cash Date: Mon, 26 May 2008 15:48:22 -0400 Subject: [PATCH 04/71] Spelling error, more tests --- extra/lisp/lisp-tests.factor | 25 ++++++++++++++++--------- extra/lisp/lisp.factor | 5 ++++- 2 files changed, 20 insertions(+), 10 deletions(-) diff --git a/extra/lisp/lisp-tests.factor b/extra/lisp/lisp-tests.factor index 0312080907..e260857a37 100644 --- a/extra/lisp/lisp-tests.factor +++ b/extra/lisp/lisp-tests.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 James Cash ! See http://factorcode.org/license.txt for BSD license. -USING: lisp lisp.parser tools.test sequences math kernel parser ; +USING: lisp lisp.parser tools.test sequences math kernel parser arrays ; IN: lisp.test @@ -10,8 +10,11 @@ IN: lisp.test "#f" [ f ] lisp-define "#t" [ t ] lisp-define - "+" "math" "+" define-primitve - "-" "math" "-" define-primitve + "+" "math" "+" define-primitive + "-" "math" "-" define-primitive + + "list" [ >array ] lisp-define + "map" [ [ swap map ] compose call ] lisp-define { 5 } [ [ 2 3 ] "+" funcall @@ -22,26 +25,30 @@ IN: lisp.test ] unit-test { 3 } [ - "((lambda (x y) (+ x y)) 1 2)" lisp-string>factor call + "((lambda (x y) (+ x y)) 1 2)" lisp-eval ] unit-test { 42 } [ - "((lambda (x y z) (+ x (- y z))) 40 3 1)" lisp-string>factor call + "((lambda (x y z) (+ x (- y z))) 40 3 1)" lisp-eval ] unit-test { 1 } [ - "(if #t 1 2)" lisp-string>factor call + "(if #t 1 2)" lisp-eval ] unit-test { "b" } [ - "(cond (#f \"a\") (#t \"b\"))" lisp-string>factor call + "(cond (#f \"a\") (#t \"b\"))" lisp-eval ] unit-test { 5 } [ - "(begin (+ 1 4))" lisp-string>factor call + "(begin (+ 1 4))" lisp-eval ] unit-test { 3 } [ - "((lambda (x) (if x (begin (+ 1 2)) (- 3 5))) #t)" lisp-string>factor call + "((lambda (x) (if x (begin (+ 1 2)) (- 3 5))) #t)" lisp-eval + ] unit-test + + { { 1 2 3 4 5 } } [ + "(list 1 2 3 4 5)" lisp-eval ] unit-test ] with-interactive-vocabs \ No newline at end of file diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor index 82a331f2ca..9b2691293b 100644 --- a/extra/lisp/lisp.factor +++ b/extra/lisp/lisp.factor @@ -78,6 +78,9 @@ PRIVATE> : lisp-string>factor ( str -- quot ) lisp-expr parse-result-ast convert-form lambda-rewrite call ; +: lisp-eval ( str -- * ) + lisp-string>factor call ; + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! SYMBOL: lisp-env @@ -98,5 +101,5 @@ ERROR: no-such-var var ; : funcall ( quot sym -- * ) dup lisp-symbol? [ lookup-var ] when call ; inline -: define-primitve ( name vocab word -- ) +: define-primitive ( name vocab word -- ) swap lookup 1quotation '[ , compose call ] lisp-define ; \ No newline at end of file From 904bac28088fd682f85b1b2fe636ef867ba796e2 Mon Sep 17 00:00:00 2001 From: James Cash Date: Mon, 26 May 2008 16:52:51 -0400 Subject: [PATCH 05/71] Don't need bake anymore, using fry instead --- extra/lisp/lisp.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor index 9b2691293b..3f357d4354 100644 --- a/extra/lisp/lisp.factor +++ b/extra/lisp/lisp.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 James Cash ! See http://factorcode.org/license.txt for BSD license. USING: kernel peg sequences arrays strings combinators.lib -namespaces combinators math bake locals locals.private accessors +namespaces combinators math locals locals.private accessors vectors syntax lisp.parser assocs parser sequences.lib words quotations fry ; IN: lisp From 1f9c6d472efd976d593a4babbff413c26d58e4ab Mon Sep 17 00:00:00 2001 From: James Cash Date: Mon, 26 May 2008 17:02:23 -0400 Subject: [PATCH 06/71] Removing map test, poor implementation --- extra/lisp/lisp-tests.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/lisp/lisp-tests.factor b/extra/lisp/lisp-tests.factor index e260857a37..2358fa3f7e 100644 --- a/extra/lisp/lisp-tests.factor +++ b/extra/lisp/lisp-tests.factor @@ -14,7 +14,6 @@ IN: lisp.test "-" "math" "-" define-primitive "list" [ >array ] lisp-define - "map" [ [ swap map ] compose call ] lisp-define { 5 } [ [ 2 3 ] "+" funcall @@ -51,4 +50,5 @@ IN: lisp.test { { 1 2 3 4 5 } } [ "(list 1 2 3 4 5)" lisp-eval ] unit-test -] with-interactive-vocabs \ No newline at end of file + +] with-interactive-vocabs From bf860c8529830524db626eb595acf4e842daa722 Mon Sep 17 00:00:00 2001 From: James Cash Date: Fri, 30 May 2008 01:44:54 -0400 Subject: [PATCH 07/71] Starting work on macros --- extra/lisp/lisp.factor | 29 +++++++++++++++++++---------- 1 file changed, 19 insertions(+), 10 deletions(-) diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor index 3f357d4354..22fc053811 100644 --- a/extra/lisp/lisp.factor +++ b/extra/lisp/lisp.factor @@ -9,6 +9,7 @@ IN: lisp DEFER: convert-form DEFER: funcall DEFER: lookup-var +DEFER: lisp-macro? ! Functions to convert s-exps to quotations ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -57,17 +58,25 @@ PRIVATE> : convert-quoted ( s-exp -- quot ) second 1quotation ; +: form-dispatch ( lisp-symbol -- quot ) + name>> + { { "lambda" [ convert-lambda ] } + { "quote" [ convert-quoted ] } + { "if" [ convert-if ] } + { "begin" [ convert-begin ] } + { "cond" [ convert-cond ] } + [ drop convert-general-form ] + } case ; + +: macro-expand ( s-exp -- quot ) + ; + : convert-list-form ( s-exp -- quot ) - dup first dup lisp-symbol? - [ name>> - { { "lambda" [ convert-lambda ] } - { "quote" [ convert-quoted ] } - { "if" [ convert-if ] } - { "begin" [ convert-begin ] } - { "cond" [ convert-cond ] } - [ drop convert-general-form ] - } case ] - [ drop convert-general-form ] if ; + dup first + { { [ dup lisp-macro? ] [ macro-expand ] } + { [ dup lisp-symbol? ] [ form-dispatch ] } + [ drop convert-general-form ] + } cond ; : convert-form ( lisp-form -- quot ) { { [ dup s-exp? ] [ body>> convert-list-form ] } From 99e546ef65fd9a2e1e71a1ee998a5b0447f59b83 Mon Sep 17 00:00:00 2001 From: James Cash Date: Sun, 1 Jun 2008 00:52:47 -0400 Subject: [PATCH 08/71] More work on macros --- extra/lisp/lisp.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor index 22fc053811..28a9255293 100644 --- a/extra/lisp/lisp.factor +++ b/extra/lisp/lisp.factor @@ -10,6 +10,7 @@ DEFER: convert-form DEFER: funcall DEFER: lookup-var DEFER: lisp-macro? +DEFER: looku-macro ! Functions to convert s-exps to quotations ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -69,7 +70,7 @@ PRIVATE> } case ; : macro-expand ( s-exp -- quot ) - ; + unclip-slice lookup-macro macro-call convert-form ; : convert-list-form ( s-exp -- quot ) dup first From 27586218e82c904b7edb782f73ab936e76c17a08 Mon Sep 17 00:00:00 2001 From: James Cash Date: Sun, 1 Jun 2008 18:50:22 -0400 Subject: [PATCH 09/71] Replacing s-exp tuple with cons cells in parser, updating tests --- extra/lisp/parser/parser-tests.factor | 45 ++++++++++++++++++++------- extra/lisp/parser/parser.factor | 23 +++++++++----- 2 files changed, 49 insertions(+), 19 deletions(-) diff --git a/extra/lisp/parser/parser-tests.factor b/extra/lisp/parser/parser-tests.factor index 98a6d2a6ba..712a1f9b9e 100644 --- a/extra/lisp/parser/parser-tests.factor +++ b/extra/lisp/parser/parser-tests.factor @@ -9,38 +9,61 @@ IN: lisp.parser.tests ] unit-test { -42 } [ - "-42" "atom" \ lisp-expr rule parse parse-result-ast + "-42" "atom" \ lisp-expr rule parse parse-result-ast ] unit-test { 37/52 } [ - "37/52" "atom" \ lisp-expr rule parse parse-result-ast + "37/52" "atom" \ lisp-expr rule parse parse-result-ast ] unit-test { 123.98 } [ - "123.98" "atom" \ lisp-expr rule parse parse-result-ast + "123.98" "atom" \ lisp-expr rule parse parse-result-ast ] unit-test { "" } [ - "\"\"" "atom" \ lisp-expr rule parse parse-result-ast + "\"\"" "atom" \ lisp-expr rule parse parse-result-ast ] unit-test { "aoeu" } [ - "\"aoeu\"" "atom" \ lisp-expr rule parse parse-result-ast + "\"aoeu\"" "atom" \ lisp-expr rule parse parse-result-ast ] unit-test { "aoeu\"de" } [ - "\"aoeu\\\"de\"" "atom" \ lisp-expr rule parse parse-result-ast + "\"aoeu\\\"de\"" "atom" \ lisp-expr rule parse parse-result-ast ] unit-test { T{ lisp-symbol f "foobar" } } [ - "foobar" "atom" \ lisp-expr rule parse parse-result-ast + "foobar" "atom" \ lisp-expr rule parse parse-result-ast ] unit-test { T{ lisp-symbol f "+" } } [ - "+" "atom" \ lisp-expr rule parse parse-result-ast + "+" "atom" \ lisp-expr rule parse parse-result-ast ] unit-test -{ T{ s-exp f - V{ T{ lisp-symbol f "foo" } 1 2 "aoeu" } } } [ - "(foo 1 2 \"aoeu\")" lisp-expr parse-result-ast +{ T{ cons f f f } +} [ + "()" lisp-expr parse-result-ast +] unit-test + +{ T{ + cons + f + T{ lisp-symbol f "foo" } + T{ + cons + f + 1 + T{ cons f 2 T{ cons f "aoeu" T{ cons f f f } } } + } } } [ + "(foo 1 2 \"aoeu\")" lisp-expr parse-result-ast +] unit-test + +{ T{ cons f + 1 + T{ cons f + T{ cons f 3 T{ cons f 4 T{ cons f f f } } } + T{ cons f 2 T{ cons f f } } } + } +} [ + "(1 (3 4) 2)" lisp-expr parse-result-ast ] unit-test \ No newline at end of file diff --git a/extra/lisp/parser/parser.factor b/extra/lisp/parser/parser.factor index cf5ff56331..dad6a7dc24 100644 --- a/extra/lisp/parser/parser.factor +++ b/extra/lisp/parser/parser.factor @@ -1,16 +1,22 @@ ! Copyright (C) 2008 James Cash ! See http://factorcode.org/license.txt for BSD license. -USING: kernel peg.ebnf peg.expr math.parser sequences arrays strings -combinators.lib math ; +USING: kernel peg peg.ebnf peg.expr math.parser sequences arrays strings +combinators.lib math fry accessors ; IN: lisp.parser TUPLE: lisp-symbol name ; C: lisp-symbol -TUPLE: s-exp body ; -C: s-exp +TUPLE: cons car cdr ; +: cons \ cons new ; +: ( x -- cons ) + cons swap >>car ; + +: seq>cons ( seq -- cons ) + cons [ swap >>cdr ] reduce ; + EBNF: lisp-expr _ = (" " | "\t" | "\n")* LPAREN = "(" @@ -24,8 +30,9 @@ rational = integer "/" (digit)+ => [[ first3 nip string number = float | rational | integer -id-specials = "!" | "$" | "%" | "&" | "*" | "/" | ":" | "<" | "#" - | " =" | ">" | "?" | "^" | "_" | "~" | "+" | "-" | "." | "@" +id-specials = "!" | "$" | "%" | "&" | "*" | "/" | ":" + | "<" | "#" | " =" | ">" | "?" | "^" | "_" + | "~" | "+" | "-" | "." | "@" letters = [a-zA-Z] => [[ 1array >string ]] initials = letters | id-specials numbers = [0-9] => [[ 1array >string ]] @@ -36,6 +43,6 @@ string = dquote ( escaped | !(dquote) . )* dquote => [[ second >string ]] atom = number | identifier | string -list-item = _ (atom|s-expression) _ => [[ second ]] -s-expression = LPAREN (list-item)* RPAREN => [[ second ]] +list-item = _ ( atom | s-expression ) _ => [[ second ]] +s-expression = LPAREN (list-item)* RPAREN => [[ second seq>cons ]] ;EBNF \ No newline at end of file From f0fdac5b7d253ce3858ea26d1ee1f35e0a2c6b84 Mon Sep 17 00:00:00 2001 From: James Cash Date: Sun, 1 Jun 2008 23:59:38 -0400 Subject: [PATCH 10/71] Starting work on converting lisp.factor to use cons cells --- extra/lisp/lisp.factor | 42 +++++++++++++++++++++++------------------- 1 file changed, 23 insertions(+), 19 deletions(-) diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor index 28a9255293..59b0ccdff2 100644 --- a/extra/lisp/lisp.factor +++ b/extra/lisp/lisp.factor @@ -6,42 +6,45 @@ vectors syntax lisp.parser assocs parser sequences.lib words quotations fry ; IN: lisp +: uncons ( cons -- cdr car ) + [ cdr>> ] [ car>> ] bi ; + DEFER: convert-form DEFER: funcall DEFER: lookup-var DEFER: lisp-macro? -DEFER: looku-macro +DEFER: lookup-macro ! Functions to convert s-exps to quotations ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: convert-body ( s-exp -- quot ) +: convert-body ( cons -- quot ) [ ] [ convert-form compose ] reduce ; inline -: convert-if ( s-exp -- quot ) +: convert-if ( cons -- quot ) rest first3 [ convert-form ] tri@ '[ @ , , if ] ; -: convert-begin ( s-exp -- quot ) +: convert-begin ( cons -- quot ) rest [ convert-form ] [ ] map-as '[ , [ funcall ] each ] ; -: convert-cond ( s-exp -- quot ) +: convert-cond ( cons -- quot ) rest [ body>> first2 [ convert-form ] bi@ [ '[ @ funcall ] ] dip 2array ] { } map-as '[ , cond ] ; -: convert-general-form ( s-exp -- quot ) - unclip convert-form swap convert-body swap '[ , @ funcall ] ; +: convert-general-form ( cons -- quot ) + uncons convert-form swap convert-body swap '[ , @ funcall ] ; ! words for convert-lambda > ] dip at swap or ] - [ dup s-exp? [ body>> localize-body ] when ] if + [ dup cons? [ body>> localize-body ] when ] if ] map ; : localize-lambda ( body vars -- newbody newvars ) make-locals dup push-locals swap [ swap localize-body convert-form swap pop-locals ] dip swap ; -: split-lambda ( s-exp -- body vars ) +: split-lambda ( cons -- body vars ) first3 -rot nip [ body>> ] bi@ [ name>> ] map ; inline : rest-lambda ( body vars -- quot ) @@ -53,11 +56,11 @@ DEFER: looku-macro localize-lambda '[ , compose ] ; PRIVATE> -: convert-lambda ( s-exp -- quot ) +: convert-lambda ( cons -- quot ) split-lambda "&rest" over member? [ rest-lambda ] [ normal-lambda ] if ; -: convert-quoted ( s-exp -- quot ) - second 1quotation ; +: convert-quoted ( cons -- quot ) + cdr>> 1quotation ; : form-dispatch ( lisp-symbol -- quot ) name>> @@ -69,20 +72,21 @@ PRIVATE> [ drop convert-general-form ] } case ; -: macro-expand ( s-exp -- quot ) - unclip-slice lookup-macro macro-call convert-form ; +: macro-expand ( cons -- quot ) + uncons lookup-macro macro-call convert-form ; -: convert-list-form ( s-exp -- quot ) - dup first +: convert-list-form ( cons -- quot ) + dup car>> { { [ dup lisp-macro? ] [ macro-expand ] } { [ dup lisp-symbol? ] [ form-dispatch ] } [ drop convert-general-form ] } cond ; : convert-form ( lisp-form -- quot ) - { { [ dup s-exp? ] [ body>> convert-list-form ] } - { [ dup lisp-symbol? ] [ '[ , lookup-var ] ] } - [ 1quotation ] + { + { [ dup cons? ] [ convert-list-form ] } + { [ dup lisp-symbol? ] [ '[ , lookup-var ] ] } + [ 1quotation ] } cond ; : lisp-string>factor ( str -- quot ) From c65e299e8c9bbe2d460203e4fd38219333f286cc Mon Sep 17 00:00:00 2001 From: James Cash Date: Mon, 2 Jun 2008 01:26:10 -0400 Subject: [PATCH 11/71] Moving cons stuff into its own sub-vocab --- extra/lisp/conses/authors.txt | 1 + extra/lisp/conses/conses-docs.factor | 0 extra/lisp/conses/conses-tests.factor | 13 +++++++++++++ extra/lisp/conses/conses.factor | 26 ++++++++++++++++++++++++++ extra/lisp/conses/summary.txt | 1 + extra/lisp/conses/tags.txt | 4 ++++ extra/lisp/lisp.factor | 5 +---- extra/lisp/parser/parser-tests.factor | 2 +- extra/lisp/parser/parser.factor | 11 +---------- 9 files changed, 48 insertions(+), 15 deletions(-) create mode 100644 extra/lisp/conses/authors.txt create mode 100644 extra/lisp/conses/conses-docs.factor create mode 100644 extra/lisp/conses/conses-tests.factor create mode 100644 extra/lisp/conses/conses.factor create mode 100644 extra/lisp/conses/summary.txt create mode 100644 extra/lisp/conses/tags.txt diff --git a/extra/lisp/conses/authors.txt b/extra/lisp/conses/authors.txt new file mode 100644 index 0000000000..4b7af4aac0 --- /dev/null +++ b/extra/lisp/conses/authors.txt @@ -0,0 +1 @@ +James Cash diff --git a/extra/lisp/conses/conses-docs.factor b/extra/lisp/conses/conses-docs.factor new file mode 100644 index 0000000000..e69de29bb2 diff --git a/extra/lisp/conses/conses-tests.factor b/extra/lisp/conses/conses-tests.factor new file mode 100644 index 0000000000..e4288a2e11 --- /dev/null +++ b/extra/lisp/conses/conses-tests.factor @@ -0,0 +1,13 @@ +! Copyright (C) 2008 James Cash +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test lisp.conses math ; + +IN: lisp.conses.tests + +{ { 3 4 5 6 } } [ + T{ cons f 1 + T{ cons f 2 + T{ cons f 3 + T{ cons f 4 + T{ cons f f f } } } } } [ 2 + ] map-cons +] unit-test \ No newline at end of file diff --git a/extra/lisp/conses/conses.factor b/extra/lisp/conses/conses.factor new file mode 100644 index 0000000000..3fdbc25b0e --- /dev/null +++ b/extra/lisp/conses/conses.factor @@ -0,0 +1,26 @@ +! Copyright (C) 2008 James Cash +! See http://factorcode.org/license.txt for BSD license. +USING: kernel sequences accessors ; + +IN: lisp.conses + +TUPLE: cons car cdr ; +: cons \ cons new ; + +: uncons ( cons -- cdr car ) + [ cdr>> ] [ car>> ] bi ; + +: null? ( cons -- ? ) + uncons and not ; + +: ( x -- cons ) + cons swap >>car ; + +: seq>cons ( seq -- cons ) + cons [ swap >>cdr ] reduce ; + +: (map-cons) ( acc cons quot -- seq ) + over null? [ 2drop ] [ [ uncons ] dip [ call ] keep swapd [ suffix ] 2dip (map-cons) ] if ; + +: map-cons ( cons quot -- seq ) + [ { } clone ] 2dip (map-cons) ; \ No newline at end of file diff --git a/extra/lisp/conses/summary.txt b/extra/lisp/conses/summary.txt new file mode 100644 index 0000000000..d69b63b233 --- /dev/null +++ b/extra/lisp/conses/summary.txt @@ -0,0 +1 @@ +Cons cell helper functions for extra/lisp diff --git a/extra/lisp/conses/tags.txt b/extra/lisp/conses/tags.txt new file mode 100644 index 0000000000..a3f9681acb --- /dev/null +++ b/extra/lisp/conses/tags.txt @@ -0,0 +1,4 @@ +lisp +cons +lists +sequences diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor index 59b0ccdff2..3d977df97f 100644 --- a/extra/lisp/lisp.factor +++ b/extra/lisp/lisp.factor @@ -3,12 +3,9 @@ USING: kernel peg sequences arrays strings combinators.lib namespaces combinators math locals locals.private accessors vectors syntax lisp.parser assocs parser sequences.lib words quotations -fry ; +fry lisp.conses ; IN: lisp -: uncons ( cons -- cdr car ) - [ cdr>> ] [ car>> ] bi ; - DEFER: convert-form DEFER: funcall DEFER: lookup-var diff --git a/extra/lisp/parser/parser-tests.factor b/extra/lisp/parser/parser-tests.factor index 712a1f9b9e..9c33f635f9 100644 --- a/extra/lisp/parser/parser-tests.factor +++ b/extra/lisp/parser/parser-tests.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 James Cash ! See http://factorcode.org/license.txt for BSD license. -USING: lisp.parser tools.test peg peg.ebnf ; +USING: lisp.parser tools.test peg peg.ebnf lisp.conses ; IN: lisp.parser.tests diff --git a/extra/lisp/parser/parser.factor b/extra/lisp/parser/parser.factor index dad6a7dc24..9679c77209 100644 --- a/extra/lisp/parser/parser.factor +++ b/extra/lisp/parser/parser.factor @@ -1,22 +1,13 @@ ! Copyright (C) 2008 James Cash ! See http://factorcode.org/license.txt for BSD license. USING: kernel peg peg.ebnf peg.expr math.parser sequences arrays strings -combinators.lib math fry accessors ; +combinators.lib math fry accessors lisp.conses ; IN: lisp.parser TUPLE: lisp-symbol name ; C: lisp-symbol -TUPLE: cons car cdr ; -: cons \ cons new ; - -: ( x -- cons ) - cons swap >>car ; - -: seq>cons ( seq -- cons ) - cons [ swap >>cdr ] reduce ; - EBNF: lisp-expr _ = (" " | "\t" | "\n")* LPAREN = "(" From 25fa0248987861d33a00c0f1bbdc6bc9fc0a38ef Mon Sep 17 00:00:00 2001 From: James Cash Date: Mon, 2 Jun 2008 14:13:48 -0400 Subject: [PATCH 12/71] Reduce for conses --- extra/lisp/conses/conses.factor | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/extra/lisp/conses/conses.factor b/extra/lisp/conses/conses.factor index 3fdbc25b0e..c715ac890a 100644 --- a/extra/lisp/conses/conses.factor +++ b/extra/lisp/conses/conses.factor @@ -20,7 +20,12 @@ TUPLE: cons car cdr ; cons [ swap >>cdr ] reduce ; : (map-cons) ( acc cons quot -- seq ) - over null? [ 2drop ] [ [ uncons ] dip [ call ] keep swapd [ suffix ] 2dip (map-cons) ] if ; + over null? [ 2drop ] + [ [ uncons ] dip [ call ] keep swapd [ suffix ] 2dip (map-cons) ] if ; : map-cons ( cons quot -- seq ) - [ { } clone ] 2dip (map-cons) ; \ No newline at end of file + [ { } clone ] 2dip (map-cons) ; + +: reduce-cons ( cons identity quot -- result ) + pick null? [ drop nip ] + [ [ uncons ] 2dip swapd [ call ] keep reduce-cons ] if ; \ No newline at end of file From d0edbccf67335762fcbca7b24d2feeba591787e3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 2 Jun 2008 21:59:23 -0500 Subject: [PATCH 13/71] Fix default main responder --- extra/http/server/server.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index 02424ef974..756a0de0ff 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -22,7 +22,7 @@ C: trivial-responder M: trivial-responder call-responder* nip response>> clone ; -main-responder global [ <404> get-global or ] change-at +main-responder global [ <404> or ] change-at : invert-slice ( slice -- slice' ) dup slice? [ [ seq>> ] [ from>> ] bi head-slice ] [ drop { } ] if ; From cfc3381cabd9de8f82e0f1c519a52efdf5589dd9 Mon Sep 17 00:00:00 2001 From: James Cash Date: Tue, 3 Jun 2008 01:27:06 -0400 Subject: [PATCH 14/71] Moving extra/lisp/conses to extra/lists --- extra/lisp/conses/summary.txt | 1 - extra/{lisp/conses => lists}/authors.txt | 0 .../conses-docs.factor => lists/lists-docs.factor} | 0 .../conses-tests.factor => lists/lists-tests.factor} | 12 ++++++++++-- .../conses/conses.factor => lists/lists.factor} | 5 ++++- extra/lists/summary.txt | 1 + extra/{lisp/conses => lists}/tags.txt | 1 - 7 files changed, 15 insertions(+), 5 deletions(-) delete mode 100644 extra/lisp/conses/summary.txt rename extra/{lisp/conses => lists}/authors.txt (100%) rename extra/{lisp/conses/conses-docs.factor => lists/lists-docs.factor} (100%) rename extra/{lisp/conses/conses-tests.factor => lists/lists-tests.factor} (52%) rename extra/{lisp/conses/conses.factor => lists/lists.factor} (84%) create mode 100644 extra/lists/summary.txt rename extra/{lisp/conses => lists}/tags.txt (80%) diff --git a/extra/lisp/conses/summary.txt b/extra/lisp/conses/summary.txt deleted file mode 100644 index d69b63b233..0000000000 --- a/extra/lisp/conses/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Cons cell helper functions for extra/lisp diff --git a/extra/lisp/conses/authors.txt b/extra/lists/authors.txt similarity index 100% rename from extra/lisp/conses/authors.txt rename to extra/lists/authors.txt diff --git a/extra/lisp/conses/conses-docs.factor b/extra/lists/lists-docs.factor similarity index 100% rename from extra/lisp/conses/conses-docs.factor rename to extra/lists/lists-docs.factor diff --git a/extra/lisp/conses/conses-tests.factor b/extra/lists/lists-tests.factor similarity index 52% rename from extra/lisp/conses/conses-tests.factor rename to extra/lists/lists-tests.factor index e4288a2e11..41f2d1d356 100644 --- a/extra/lisp/conses/conses-tests.factor +++ b/extra/lists/lists-tests.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008 James Cash ! See http://factorcode.org/license.txt for BSD license. -USING: tools.test lisp.conses math ; +USING: tools.test lists math ; -IN: lisp.conses.tests +IN: lists.tests { { 3 4 5 6 } } [ T{ cons f 1 @@ -10,4 +10,12 @@ IN: lisp.conses.tests T{ cons f 3 T{ cons f 4 T{ cons f f f } } } } } [ 2 + ] map-cons +] unit-test + +{ 10 } [ + T{ cons f 1 + T{ cons f 2 + T{ cons f 3 + T{ cons f 4 + T{ cons f f f } } } } } 0 [ + ] reduce-cons ] unit-test \ No newline at end of file diff --git a/extra/lisp/conses/conses.factor b/extra/lists/lists.factor similarity index 84% rename from extra/lisp/conses/conses.factor rename to extra/lists/lists.factor index c715ac890a..da26580305 100644 --- a/extra/lisp/conses/conses.factor +++ b/extra/lists/lists.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences accessors ; -IN: lisp.conses +IN: lists TUPLE: cons car cdr ; : cons \ cons new ; @@ -26,6 +26,9 @@ TUPLE: cons car cdr ; : map-cons ( cons quot -- seq ) [ { } clone ] 2dip (map-cons) ; +: cons>seq ( cons -- array ) + [ ] map-cons ; + : reduce-cons ( cons identity quot -- result ) pick null? [ drop nip ] [ [ uncons ] 2dip swapd [ call ] keep reduce-cons ] if ; \ No newline at end of file diff --git a/extra/lists/summary.txt b/extra/lists/summary.txt new file mode 100644 index 0000000000..60a18867ab --- /dev/null +++ b/extra/lists/summary.txt @@ -0,0 +1 @@ +Implementation of lisp-style linked lists diff --git a/extra/lisp/conses/tags.txt b/extra/lists/tags.txt similarity index 80% rename from extra/lisp/conses/tags.txt rename to extra/lists/tags.txt index a3f9681acb..e44334b2b5 100644 --- a/extra/lisp/conses/tags.txt +++ b/extra/lists/tags.txt @@ -1,4 +1,3 @@ -lisp cons lists sequences From 5361928f15a59da43e09ec843ddfc219778d6fa5 Mon Sep 17 00:00:00 2001 From: James Cash Date: Tue, 3 Jun 2008 03:38:56 -0400 Subject: [PATCH 15/71] Refactoring lazy-lists to use new accessors --- extra/lazy-lists/lazy-lists-docs.factor | 2 +- extra/lazy-lists/lazy-lists-tests.factor | 2 +- extra/lazy-lists/lazy-lists.factor | 155 +++++++++-------------- extra/lists/lists.factor | 48 +++++-- 4 files changed, 97 insertions(+), 110 deletions(-) diff --git a/extra/lazy-lists/lazy-lists-docs.factor b/extra/lazy-lists/lazy-lists-docs.factor index b240b3fbc2..fb87bee10f 100644 --- a/extra/lazy-lists/lazy-lists-docs.factor +++ b/extra/lazy-lists/lazy-lists-docs.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006 Chris Double. ! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax sequences strings ; +USING: help.markup help.syntax sequences strings lists ; IN: lazy-lists { car cons cdr nil nil? list? uncons } related-words diff --git a/extra/lazy-lists/lazy-lists-tests.factor b/extra/lazy-lists/lazy-lists-tests.factor index 302299b452..7dd0c0f009 100644 --- a/extra/lazy-lists/lazy-lists-tests.factor +++ b/extra/lazy-lists/lazy-lists-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006 Matthew Willis and Chris Double. ! See http://factorcode.org/license.txt for BSD license. ! -USING: lazy-lists tools.test kernel math io sequences ; +USING: lists lazy-lists tools.test kernel math io sequences ; IN: lazy-lists.tests [ { 1 2 3 4 } ] [ diff --git a/extra/lazy-lists/lazy-lists.factor b/extra/lazy-lists/lazy-lists.factor index 6db82ed2c1..ae123580f7 100644 --- a/extra/lazy-lists/lazy-lists.factor +++ b/extra/lazy-lists/lazy-lists.factor @@ -5,15 +5,9 @@ ! Updated by Chris Double, September 2006 ! USING: kernel sequences math vectors arrays namespaces -quotations promises combinators io ; +quotations promises combinators io lists accessors ; IN: lazy-lists -! Lazy List Protocol -MIXIN: list -GENERIC: car ( cons -- car ) -GENERIC: cdr ( cons -- cdr ) -GENERIC: nil? ( cons -- ? ) - M: promise car ( promise -- car ) force car ; @@ -22,32 +16,7 @@ M: promise cdr ( promise -- cdr ) M: promise nil? ( cons -- bool ) force nil? ; - -TUPLE: cons car cdr ; - -C: cons cons - -M: cons car ( cons -- car ) - cons-car ; - -M: cons cdr ( cons -- cdr ) - cons-cdr ; - -: nil ( -- cons ) - T{ cons f f f } ; - -M: cons nil? ( cons -- bool ) - nil eq? ; - -: 1list ( obj -- cons ) - nil cons ; - -: 2list ( a b -- cons ) - nil cons cons ; - -: 3list ( a b c -- cons ) - nil cons cons cons ; - + ! Both 'car' and 'cdr' are promises TUPLE: lazy-cons car cdr ; @@ -57,10 +26,10 @@ TUPLE: lazy-cons car cdr ; [ set-promise-value ] keep ; M: lazy-cons car ( lazy-cons -- car ) - lazy-cons-car force ; + car>> force ; M: lazy-cons cdr ( lazy-cons -- cdr ) - lazy-cons-cdr force ; + cdr>> force ; M: lazy-cons nil? ( lazy-cons -- bool ) nil eq? ; @@ -83,12 +52,8 @@ M: lazy-cons nil? ( lazy-cons -- bool ) : llength ( list -- n ) 0 (llength) ; -: uncons ( cons -- car cdr ) - #! Return the car and cdr of the lazy list - dup car swap cdr ; - : leach ( list quot -- ) - swap dup nil? [ 2drop ] [ uncons swapd over 2slip leach ] if ; inline + over nil? [ 2drop ] [ [ uncons ] dip tuck call leach ] if ; inline : lreduce ( list identity quot -- result ) swapd leach ; inline @@ -106,24 +71,24 @@ TUPLE: memoized-cons original car cdr nil? ; memoized-cons boa ; M: memoized-cons car ( memoized-cons -- car ) - dup memoized-cons-car not-memoized? [ - dup memoized-cons-original car [ swap set-memoized-cons-car ] keep + dup car>> not-memoized? [ + dup original>> car [ >>car drop ] keep ] [ - memoized-cons-car + car>> ] if ; M: memoized-cons cdr ( memoized-cons -- cdr ) - dup memoized-cons-cdr not-memoized? [ - dup memoized-cons-original cdr [ swap set-memoized-cons-cdr ] keep + dup cdr>> not-memoized? [ + dup original>> cdr [ >>cdr drop ] keep ] [ - memoized-cons-cdr + cdr>> ] if ; M: memoized-cons nil? ( memoized-cons -- bool ) - dup memoized-cons-nil? not-memoized? [ - dup memoized-cons-original nil? [ swap set-memoized-cons-nil? ] keep + dup nil?>> not-memoized? [ + dup original>> nil? [ >>nil? drop ] keep ] [ - memoized-cons-nil? + nil?>> ] if ; TUPLE: lazy-map cons quot ; @@ -134,15 +99,15 @@ C: lazy-map over nil? [ 2drop nil ] [ ] if ; M: lazy-map car ( lazy-map -- car ) - [ lazy-map-cons car ] keep - lazy-map-quot call ; + [ cons>> car ] keep + quot>> call ; M: lazy-map cdr ( lazy-map -- cdr ) - [ lazy-map-cons cdr ] keep - lazy-map-quot lmap ; + [ cons>> cdr ] keep + quot>> lmap ; M: lazy-map nil? ( lazy-map -- bool ) - lazy-map-cons nil? ; + cons>> nil? ; : lmap-with ( value list quot -- result ) with lmap ; @@ -155,17 +120,17 @@ C: lazy-take over zero? [ 2drop nil ] [ ] if ; M: lazy-take car ( lazy-take -- car ) - lazy-take-cons car ; + cons>> car ; M: lazy-take cdr ( lazy-take -- cdr ) - [ lazy-take-n 1- ] keep - lazy-take-cons cdr ltake ; + [ n>> 1- ] keep + cons>> cdr ltake ; M: lazy-take nil? ( lazy-take -- bool ) - dup lazy-take-n zero? [ + dup n>> zero? [ drop t ] [ - lazy-take-cons nil? + cons>> nil? ] if ; TUPLE: lazy-until cons quot ; @@ -176,10 +141,10 @@ C: lazy-until over nil? [ drop ] [ ] if ; M: lazy-until car ( lazy-until -- car ) - lazy-until-cons car ; + cons>> car ; M: lazy-until cdr ( lazy-until -- cdr ) - [ lazy-until-cons uncons swap ] keep lazy-until-quot tuck call + [ cons>> uncons ] keep quot>> tuck call [ 2drop nil ] [ luntil ] if ; M: lazy-until nil? ( lazy-until -- bool ) @@ -193,13 +158,13 @@ C: lazy-while over nil? [ drop ] [ ] if ; M: lazy-while car ( lazy-while -- car ) - lazy-while-cons car ; + cons>> car ; M: lazy-while cdr ( lazy-while -- cdr ) - [ lazy-while-cons cdr ] keep lazy-while-quot lwhile ; + [ cons>> cdr ] keep quot>> lwhile ; M: lazy-while nil? ( lazy-while -- bool ) - [ car ] keep lazy-while-quot call not ; + [ car ] keep quot>> call not ; TUPLE: lazy-filter cons quot ; @@ -209,26 +174,25 @@ C: lazy-filter over nil? [ 2drop nil ] [ ] if ; : car-filter? ( lazy-filter -- ? ) - [ lazy-filter-cons car ] keep - lazy-filter-quot call ; + [ cons>> car ] keep + quot>> call ; : skip ( lazy-filter -- ) - [ lazy-filter-cons cdr ] keep - set-lazy-filter-cons ; + dup cons>> cdr >>cons ; M: lazy-filter car ( lazy-filter -- car ) - dup car-filter? [ lazy-filter-cons ] [ dup skip ] if car ; + dup car-filter? [ cons>> ] [ dup skip ] if car ; M: lazy-filter cdr ( lazy-filter -- cdr ) dup car-filter? [ - [ lazy-filter-cons cdr ] keep - lazy-filter-quot lfilter + [ cons>> cdr ] keep + quot>> lfilter ] [ dup skip cdr ] if ; M: lazy-filter nil? ( lazy-filter -- bool ) - dup lazy-filter-cons nil? [ + dup cons>> nil? [ drop t ] [ dup car-filter? [ @@ -252,11 +216,11 @@ C: lazy-append over nil? [ nip ] [ ] if ; M: lazy-append car ( lazy-append -- car ) - lazy-append-list1 car ; + list1>> car ; M: lazy-append cdr ( lazy-append -- cdr ) - [ lazy-append-list1 cdr ] keep - lazy-append-list2 lappend ; + [ list1>> cdr ] keep + list2>> lappend ; M: lazy-append nil? ( lazy-append -- bool ) drop f ; @@ -269,11 +233,11 @@ C: lfrom-by lazy-from-by ( n quot -- list ) [ 1+ ] lfrom-by ; M: lazy-from-by car ( lazy-from-by -- car ) - lazy-from-by-n ; + n>> ; M: lazy-from-by cdr ( lazy-from-by -- cdr ) - [ lazy-from-by-n ] keep - lazy-from-by-quot dup slip lfrom-by ; + [ n>> ] keep + quot>> dup slip lfrom-by ; M: lazy-from-by nil? ( lazy-from-by -- bool ) drop f ; @@ -287,10 +251,10 @@ C: lazy-zip [ 2drop nil ] [ ] if ; M: lazy-zip car ( lazy-zip -- car ) - [ lazy-zip-list1 car ] keep lazy-zip-list2 car 2array ; + [ list1>> car ] keep list2>> car 2array ; M: lazy-zip cdr ( lazy-zip -- cdr ) - [ lazy-zip-list1 cdr ] keep lazy-zip-list2 cdr lzip ; + [ list1>> cdr ] keep list2>> cdr lzip ; M: lazy-zip nil? ( lazy-zip -- bool ) drop f ; @@ -307,12 +271,12 @@ C: sequence-cons ] if ; M: sequence-cons car ( sequence-cons -- car ) - [ sequence-cons-index ] keep - sequence-cons-seq nth ; + [ index>> ] keep + seq>> nth ; M: sequence-cons cdr ( sequence-cons -- cdr ) - [ sequence-cons-index 1+ ] keep - sequence-cons-seq seq>list ; + [ index>> 1+ ] keep + seq>> seq>list ; M: sequence-cons nil? ( sequence-cons -- bool ) drop f ; @@ -341,18 +305,18 @@ DEFER: lconcat dup nil? [ drop nil ] [ - uncons (lconcat) + uncons swap (lconcat) ] if ; M: lazy-concat car ( lazy-concat -- car ) - lazy-concat-car car ; + car>> car ; M: lazy-concat cdr ( lazy-concat -- cdr ) - [ lazy-concat-car cdr ] keep lazy-concat-cdr (lconcat) ; + [ car>> cdr ] keep cdr>> (lconcat) ; M: lazy-concat nil? ( lazy-concat -- bool ) - dup lazy-concat-car nil? [ - lazy-concat-cdr nil? + dup car>> nil? [ + cdr>> nil? ] [ drop f ] if ; @@ -404,22 +368,22 @@ C: lazy-io f f [ stream-readln ] ; M: lazy-io car ( lazy-io -- car ) - dup lazy-io-car dup [ + dup car>> dup [ nip ] [ - drop dup lazy-io-stream over lazy-io-quot call + drop dup stream>> over quot>> call swap dupd set-lazy-io-car ] if ; M: lazy-io cdr ( lazy-io -- cdr ) - dup lazy-io-cdr dup [ + dup cdr>> dup [ nip ] [ drop dup - [ lazy-io-stream ] keep - [ lazy-io-quot ] keep + [ stream>> ] keep + [ quot>> ] keep car [ - [ f f ] dip [ swap set-lazy-io-cdr ] keep + [ f f ] dip [ >>cdr drop ] keep ] [ 3drop nil ] if @@ -428,7 +392,6 @@ M: lazy-io cdr ( lazy-io -- cdr ) M: lazy-io nil? ( lazy-io -- bool ) car not ; -INSTANCE: cons list INSTANCE: sequence-cons list INSTANCE: memoized-cons list INSTANCE: promise list diff --git a/extra/lists/lists.factor b/extra/lists/lists.factor index da26580305..4b8cc77658 100644 --- a/extra/lists/lists.factor +++ b/extra/lists/lists.factor @@ -4,23 +4,45 @@ USING: kernel sequences accessors ; IN: lists +! Lazy List Protocol +MIXIN: list +GENERIC: car ( cons -- car ) +GENERIC: cdr ( cons -- cdr ) +GENERIC: nil? ( cons -- ? ) + TUPLE: cons car cdr ; -: cons \ cons new ; + +C: cons cons + +M: cons car ( cons -- car ) + car>> ; + +M: cons cdr ( cons -- cdr ) + cdr>> ; + +: nil ( -- cons ) + T{ cons f f f } ; + +M: cons nil? ( cons -- bool ) + nil eq? ; + +: 1list ( obj -- cons ) + nil cons ; + +: 2list ( a b -- cons ) + nil cons cons ; + +: 3list ( a b c -- cons ) + nil cons cons cons ; : uncons ( cons -- cdr car ) - [ cdr>> ] [ car>> ] bi ; - -: null? ( cons -- ? ) - uncons and not ; - -: ( x -- cons ) - cons swap >>car ; + [ cdr ] [ car ] bi ; : seq>cons ( seq -- cons ) - cons [ swap >>cdr ] reduce ; + nil [ f cons swap >>cdr ] reduce ; : (map-cons) ( acc cons quot -- seq ) - over null? [ 2drop ] + over nil? [ 2drop ] [ [ uncons ] dip [ call ] keep swapd [ suffix ] 2dip (map-cons) ] if ; : map-cons ( cons quot -- seq ) @@ -30,5 +52,7 @@ TUPLE: cons car cdr ; [ ] map-cons ; : reduce-cons ( cons identity quot -- result ) - pick null? [ drop nip ] - [ [ uncons ] 2dip swapd [ call ] keep reduce-cons ] if ; \ No newline at end of file + pick nil? [ drop nip ] + [ [ uncons ] 2dip swapd [ call ] keep reduce-cons ] if ; + +INSTANCE: cons list \ No newline at end of file From 684dde97df3bcba8deb2c67b979dcd50defac1cd Mon Sep 17 00:00:00 2001 From: James Cash Date: Tue, 3 Jun 2008 03:42:13 -0400 Subject: [PATCH 16/71] Changing indentation from 2 spaces to 4 --- extra/lazy-lists/lazy-lists.factor | 332 ++++++++++++++--------------- 1 file changed, 166 insertions(+), 166 deletions(-) diff --git a/extra/lazy-lists/lazy-lists.factor b/extra/lazy-lists/lazy-lists.factor index ae123580f7..a4b5c06daf 100644 --- a/extra/lazy-lists/lazy-lists.factor +++ b/extra/lazy-lists/lazy-lists.factor @@ -9,14 +9,14 @@ quotations promises combinators io lists accessors ; IN: lazy-lists M: promise car ( promise -- car ) - force car ; + force car ; M: promise cdr ( promise -- cdr ) - force cdr ; + force cdr ; M: promise nil? ( cons -- bool ) - force nil? ; - + force nil? ; + ! Both 'car' and 'cdr' are promises TUPLE: lazy-cons car cdr ; @@ -35,258 +35,258 @@ M: lazy-cons nil? ( lazy-cons -- bool ) nil eq? ; : 1lazy-list ( a -- lazy-cons ) - [ nil ] lazy-cons ; + [ nil ] lazy-cons ; : 2lazy-list ( a b -- lazy-cons ) - 1lazy-list 1quotation lazy-cons ; + 1lazy-list 1quotation lazy-cons ; : 3lazy-list ( a b c -- lazy-cons ) - 2lazy-list 1quotation lazy-cons ; + 2lazy-list 1quotation lazy-cons ; : lnth ( n list -- elt ) - swap [ cdr ] times car ; + swap [ cdr ] times car ; : (llength) ( list acc -- n ) - over nil? [ nip ] [ [ cdr ] dip 1+ (llength) ] if ; + over nil? [ nip ] [ [ cdr ] dip 1+ (llength) ] if ; : llength ( list -- n ) - 0 (llength) ; + 0 (llength) ; : leach ( list quot -- ) - over nil? [ 2drop ] [ [ uncons ] dip tuck call leach ] if ; inline + over nil? [ 2drop ] [ [ uncons ] dip tuck call leach ] if ; inline : lreduce ( list identity quot -- result ) - swapd leach ; inline + swapd leach ; inline TUPLE: memoized-cons original car cdr nil? ; : not-memoized ( -- obj ) - { } ; + { } ; : not-memoized? ( obj -- bool ) - not-memoized eq? ; + not-memoized eq? ; : ( cons -- memoized-cons ) - not-memoized not-memoized not-memoized - memoized-cons boa ; + not-memoized not-memoized not-memoized + memoized-cons boa ; M: memoized-cons car ( memoized-cons -- car ) - dup car>> not-memoized? [ - dup original>> car [ >>car drop ] keep - ] [ - car>> - ] if ; + dup car>> not-memoized? [ + dup original>> car [ >>car drop ] keep + ] [ + car>> + ] if ; M: memoized-cons cdr ( memoized-cons -- cdr ) - dup cdr>> not-memoized? [ - dup original>> cdr [ >>cdr drop ] keep - ] [ - cdr>> - ] if ; + dup cdr>> not-memoized? [ + dup original>> cdr [ >>cdr drop ] keep + ] [ + cdr>> + ] if ; M: memoized-cons nil? ( memoized-cons -- bool ) - dup nil?>> not-memoized? [ - dup original>> nil? [ >>nil? drop ] keep - ] [ - nil?>> - ] if ; + dup nil?>> not-memoized? [ + dup original>> nil? [ >>nil? drop ] keep + ] [ + nil?>> + ] if ; TUPLE: lazy-map cons quot ; C: lazy-map : lmap ( list quot -- result ) - over nil? [ 2drop nil ] [ ] if ; + over nil? [ 2drop nil ] [ ] if ; M: lazy-map car ( lazy-map -- car ) - [ cons>> car ] keep - quot>> call ; + [ cons>> car ] keep + quot>> call ; M: lazy-map cdr ( lazy-map -- cdr ) - [ cons>> cdr ] keep - quot>> lmap ; + [ cons>> cdr ] keep + quot>> lmap ; M: lazy-map nil? ( lazy-map -- bool ) - cons>> nil? ; + cons>> nil? ; : lmap-with ( value list quot -- result ) - with lmap ; + with lmap ; TUPLE: lazy-take n cons ; C: lazy-take : ltake ( n list -- result ) - over zero? [ 2drop nil ] [ ] if ; + over zero? [ 2drop nil ] [ ] if ; M: lazy-take car ( lazy-take -- car ) - cons>> car ; + cons>> car ; M: lazy-take cdr ( lazy-take -- cdr ) - [ n>> 1- ] keep - cons>> cdr ltake ; + [ n>> 1- ] keep + cons>> cdr ltake ; M: lazy-take nil? ( lazy-take -- bool ) - dup n>> zero? [ - drop t - ] [ - cons>> nil? - ] if ; + dup n>> zero? [ + drop t + ] [ + cons>> nil? + ] if ; TUPLE: lazy-until cons quot ; C: lazy-until : luntil ( list quot -- result ) - over nil? [ drop ] [ ] if ; + over nil? [ drop ] [ ] if ; M: lazy-until car ( lazy-until -- car ) - cons>> car ; + cons>> car ; M: lazy-until cdr ( lazy-until -- cdr ) - [ cons>> uncons ] keep quot>> tuck call - [ 2drop nil ] [ luntil ] if ; + [ cons>> uncons ] keep quot>> tuck call + [ 2drop nil ] [ luntil ] if ; M: lazy-until nil? ( lazy-until -- bool ) - drop f ; + drop f ; TUPLE: lazy-while cons quot ; C: lazy-while : lwhile ( list quot -- result ) - over nil? [ drop ] [ ] if ; + over nil? [ drop ] [ ] if ; M: lazy-while car ( lazy-while -- car ) - cons>> car ; + cons>> car ; M: lazy-while cdr ( lazy-while -- cdr ) - [ cons>> cdr ] keep quot>> lwhile ; + [ cons>> cdr ] keep quot>> lwhile ; M: lazy-while nil? ( lazy-while -- bool ) - [ car ] keep quot>> call not ; + [ car ] keep quot>> call not ; TUPLE: lazy-filter cons quot ; C: lazy-filter : lfilter ( list quot -- result ) - over nil? [ 2drop nil ] [ ] if ; + over nil? [ 2drop nil ] [ ] if ; -: car-filter? ( lazy-filter -- ? ) - [ cons>> car ] keep - quot>> call ; +: car-filter? ( lazy-filter -- ? ) + [ cons>> car ] keep + quot>> call ; : skip ( lazy-filter -- ) - dup cons>> cdr >>cons ; + dup cons>> cdr >>cons ; M: lazy-filter car ( lazy-filter -- car ) - dup car-filter? [ cons>> ] [ dup skip ] if car ; + dup car-filter? [ cons>> ] [ dup skip ] if car ; M: lazy-filter cdr ( lazy-filter -- cdr ) - dup car-filter? [ - [ cons>> cdr ] keep - quot>> lfilter - ] [ - dup skip cdr - ] if ; + dup car-filter? [ + [ cons>> cdr ] keep + quot>> lfilter + ] [ + dup skip cdr + ] if ; M: lazy-filter nil? ( lazy-filter -- bool ) - dup cons>> nil? [ - drop t - ] [ - dup car-filter? [ - drop f + dup cons>> nil? [ + drop t ] [ - dup skip nil? - ] if - ] if ; + dup car-filter? [ + drop f + ] [ + dup skip nil? + ] if + ] if ; : list>vector ( list -- vector ) - [ [ , ] leach ] V{ } make ; + [ [ , ] leach ] V{ } make ; : list>array ( list -- array ) - [ [ , ] leach ] { } make ; + [ [ , ] leach ] { } make ; TUPLE: lazy-append list1 list2 ; C: lazy-append : lappend ( list1 list2 -- result ) - over nil? [ nip ] [ ] if ; + over nil? [ nip ] [ ] if ; M: lazy-append car ( lazy-append -- car ) - list1>> car ; + list1>> car ; M: lazy-append cdr ( lazy-append -- cdr ) - [ list1>> cdr ] keep - list2>> lappend ; + [ list1>> cdr ] keep + list2>> lappend ; M: lazy-append nil? ( lazy-append -- bool ) - drop f ; + drop f ; TUPLE: lazy-from-by n quot ; C: lfrom-by lazy-from-by ( n quot -- list ) : lfrom ( n -- list ) - [ 1+ ] lfrom-by ; + [ 1+ ] lfrom-by ; M: lazy-from-by car ( lazy-from-by -- car ) - n>> ; + n>> ; M: lazy-from-by cdr ( lazy-from-by -- cdr ) - [ n>> ] keep - quot>> dup slip lfrom-by ; + [ n>> ] keep + quot>> dup slip lfrom-by ; M: lazy-from-by nil? ( lazy-from-by -- bool ) - drop f ; + drop f ; TUPLE: lazy-zip list1 list2 ; C: lazy-zip : lzip ( list1 list2 -- lazy-zip ) - over nil? over nil? or - [ 2drop nil ] [ ] if ; + over nil? over nil? or + [ 2drop nil ] [ ] if ; M: lazy-zip car ( lazy-zip -- car ) - [ list1>> car ] keep list2>> car 2array ; + [ list1>> car ] keep list2>> car 2array ; M: lazy-zip cdr ( lazy-zip -- cdr ) - [ list1>> cdr ] keep list2>> cdr lzip ; + [ list1>> cdr ] keep list2>> cdr lzip ; M: lazy-zip nil? ( lazy-zip -- bool ) - drop f ; + drop f ; TUPLE: sequence-cons index seq ; C: sequence-cons : seq>list ( index seq -- list ) - 2dup length >= [ - 2drop nil - ] [ - - ] if ; + 2dup length >= [ + 2drop nil + ] [ + + ] if ; M: sequence-cons car ( sequence-cons -- car ) - [ index>> ] keep - seq>> nth ; + [ index>> ] keep + seq>> nth ; M: sequence-cons cdr ( sequence-cons -- cdr ) - [ index>> 1+ ] keep - seq>> seq>list ; + [ index>> 1+ ] keep + seq>> seq>list ; M: sequence-cons nil? ( sequence-cons -- bool ) - drop f ; + drop f ; : >list ( object -- list ) - { - { [ dup sequence? ] [ 0 swap seq>list ] } - { [ dup list? ] [ ] } - [ "Could not convert object to a list" throw ] - } cond ; + { + { [ dup sequence? ] [ 0 swap seq>list ] } + { [ dup list? ] [ ] } + [ "Could not convert object to a list" throw ] + } cond ; TUPLE: lazy-concat car cdr ; @@ -295,102 +295,102 @@ C: lazy-concat DEFER: lconcat : (lconcat) ( car cdr -- list ) - over nil? [ - nip lconcat - ] [ - - ] if ; + over nil? [ + nip lconcat + ] [ + + ] if ; : lconcat ( list -- result ) - dup nil? [ - drop nil - ] [ - uncons swap (lconcat) - ] if ; + dup nil? [ + drop nil + ] [ + uncons swap (lconcat) + ] if ; M: lazy-concat car ( lazy-concat -- car ) - car>> car ; + car>> car ; M: lazy-concat cdr ( lazy-concat -- cdr ) - [ car>> cdr ] keep cdr>> (lconcat) ; + [ car>> cdr ] keep cdr>> (lconcat) ; M: lazy-concat nil? ( lazy-concat -- bool ) - dup car>> nil? [ - cdr>> nil? - ] [ - drop f - ] if ; + dup car>> nil? [ + cdr>> nil? + ] [ + drop f + ] if ; : lcartesian-product ( list1 list2 -- result ) - swap [ swap [ 2array ] lmap-with ] lmap-with lconcat ; + swap [ swap [ 2array ] lmap-with ] lmap-with lconcat ; : lcartesian-product* ( lists -- result ) - dup nil? [ - drop nil - ] [ - [ car ] keep cdr [ car lcartesian-product ] keep cdr list>array swap [ - swap [ swap [ suffix ] lmap-with ] lmap-with lconcat - ] reduce - ] if ; + dup nil? [ + drop nil + ] [ + [ car ] keep cdr [ car lcartesian-product ] keep cdr list>array swap [ + swap [ swap [ suffix ] lmap-with ] lmap-with lconcat + ] reduce + ] if ; : lcomp ( list quot -- result ) - [ lcartesian-product* ] dip lmap ; + [ lcartesian-product* ] dip lmap ; : lcomp* ( list guards quot -- result ) - [ [ lcartesian-product* ] dip [ lfilter ] each ] dip lmap ; + [ [ lcartesian-product* ] dip [ lfilter ] each ] dip lmap ; DEFER: lmerge : (lmerge) ( list1 list2 -- result ) - over [ car ] curry -rot - [ - dup [ car ] curry -rot + over [ car ] curry -rot [ - [ cdr ] bi@ lmerge - ] 2curry lazy-cons - ] 2curry lazy-cons ; + dup [ car ] curry -rot + [ + [ cdr ] bi@ lmerge + ] 2curry lazy-cons + ] 2curry lazy-cons ; : lmerge ( list1 list2 -- result ) - { - { [ over nil? ] [ nip ] } - { [ dup nil? ] [ drop ] } - { [ t ] [ (lmerge) ] } - } cond ; + { + { [ over nil? ] [ nip ] } + { [ dup nil? ] [ drop ] } + { [ t ] [ (lmerge) ] } + } cond ; TUPLE: lazy-io stream car cdr quot ; C: lazy-io : lcontents ( stream -- result ) - f f [ stream-read1 ] ; + f f [ stream-read1 ] ; : llines ( stream -- result ) - f f [ stream-readln ] ; + f f [ stream-readln ] ; M: lazy-io car ( lazy-io -- car ) - dup car>> dup [ - nip - ] [ - drop dup stream>> over quot>> call - swap dupd set-lazy-io-car - ] if ; + dup car>> dup [ + nip + ] [ + drop dup stream>> over quot>> call + swap dupd set-lazy-io-car + ] if ; M: lazy-io cdr ( lazy-io -- cdr ) - dup cdr>> dup [ - nip - ] [ - drop dup - [ stream>> ] keep - [ quot>> ] keep - car [ - [ f f ] dip [ >>cdr drop ] keep + dup cdr>> dup [ + nip ] [ - 3drop nil - ] if - ] if ; + drop dup + [ stream>> ] keep + [ quot>> ] keep + car [ + [ f f ] dip [ >>cdr drop ] keep + ] [ + 3drop nil + ] if + ] if ; M: lazy-io nil? ( lazy-io -- bool ) - car not ; + car not ; INSTANCE: sequence-cons list INSTANCE: memoized-cons list From 887bc84d4b8ea71c65138274818cc55a45b693b7 Mon Sep 17 00:00:00 2001 From: James Cash Date: Tue, 3 Jun 2008 03:42:56 -0400 Subject: [PATCH 17/71] Adding 'updated' notice --- extra/lazy-lists/lazy-lists.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/extra/lazy-lists/lazy-lists.factor b/extra/lazy-lists/lazy-lists.factor index a4b5c06daf..8b3d069c40 100644 --- a/extra/lazy-lists/lazy-lists.factor +++ b/extra/lazy-lists/lazy-lists.factor @@ -3,6 +3,7 @@ ! ! Updated by Matthew Willis, July 2006 ! Updated by Chris Double, September 2006 +! Updated by James Cash, June 2008 ! USING: kernel sequences math vectors arrays namespaces quotations promises combinators io lists accessors ; From 847077f77088e244c124e076bbef9a7c8930757a Mon Sep 17 00:00:00 2001 From: James Cash Date: Tue, 3 Jun 2008 03:46:29 -0400 Subject: [PATCH 18/71] Changing lisp to reflect moving extra/lisp/conses to extra/lists --- extra/lisp/lisp.factor | 21 +++++++++++---------- extra/lisp/parser/parser-tests.factor | 2 +- extra/lisp/parser/parser.factor | 2 +- 3 files changed, 13 insertions(+), 12 deletions(-) diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor index 3d977df97f..b034619d0d 100644 --- a/extra/lisp/lisp.factor +++ b/extra/lisp/lisp.factor @@ -3,7 +3,7 @@ USING: kernel peg sequences arrays strings combinators.lib namespaces combinators math locals locals.private accessors vectors syntax lisp.parser assocs parser sequences.lib words quotations -fry lisp.conses ; +fry lists ; IN: lisp DEFER: convert-form @@ -11,20 +11,21 @@ DEFER: funcall DEFER: lookup-var DEFER: lisp-macro? DEFER: lookup-macro +DEFER: macro-call ! Functions to convert s-exps to quotations ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : convert-body ( cons -- quot ) - [ ] [ convert-form compose ] reduce ; inline + [ ] [ convert-form compose ] reduce-cons ; inline : convert-if ( cons -- quot ) - rest first3 [ convert-form ] tri@ '[ @ , , if ] ; + cdr first3 [ convert-form ] tri@ '[ @ , , if ] ; : convert-begin ( cons -- quot ) - rest [ convert-form ] [ ] map-as '[ , [ funcall ] each ] ; + cdr [ convert-form ] [ ] map-as '[ , [ funcall ] each ] ; : convert-cond ( cons -- quot ) - rest [ body>> first2 [ convert-form ] bi@ [ '[ @ funcall ] ] dip 2array ] + cdr [ body>> first2 [ convert-form ] bi@ [ '[ @ funcall ] ] dip 2array ] { } map-as '[ , cond ] ; : convert-general-form ( cons -- quot ) @@ -34,12 +35,12 @@ DEFER: lookup-macro > ] dip at swap or ] - [ dup cons? [ body>> localize-body ] when ] if - ] map ; + [ dup cons? [ localize-body ] when ] if + ] map-cons ; : localize-lambda ( body vars -- newbody newvars ) make-locals dup push-locals swap - [ swap localize-body convert-form swap pop-locals ] dip swap ; + [ swap localize-body cons convert-form swap pop-locals ] dip swap ; : split-lambda ( cons -- body vars ) first3 -rot nip [ body>> ] bi@ [ name>> ] map ; inline @@ -57,7 +58,7 @@ PRIVATE> split-lambda "&rest" over member? [ rest-lambda ] [ normal-lambda ] if ; : convert-quoted ( cons -- quot ) - cdr>> 1quotation ; + cdr 1quotation ; : form-dispatch ( lisp-symbol -- quot ) name>> @@ -73,7 +74,7 @@ PRIVATE> uncons lookup-macro macro-call convert-form ; : convert-list-form ( cons -- quot ) - dup car>> + dup car { { [ dup lisp-macro? ] [ macro-expand ] } { [ dup lisp-symbol? ] [ form-dispatch ] } [ drop convert-general-form ] diff --git a/extra/lisp/parser/parser-tests.factor b/extra/lisp/parser/parser-tests.factor index 9c33f635f9..41254db5b3 100644 --- a/extra/lisp/parser/parser-tests.factor +++ b/extra/lisp/parser/parser-tests.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 James Cash ! See http://factorcode.org/license.txt for BSD license. -USING: lisp.parser tools.test peg peg.ebnf lisp.conses ; +USING: lisp.parser tools.test peg peg.ebnf lists ; IN: lisp.parser.tests diff --git a/extra/lisp/parser/parser.factor b/extra/lisp/parser/parser.factor index 9679c77209..1e37193d3a 100644 --- a/extra/lisp/parser/parser.factor +++ b/extra/lisp/parser/parser.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 James Cash ! See http://factorcode.org/license.txt for BSD license. USING: kernel peg peg.ebnf peg.expr math.parser sequences arrays strings -combinators.lib math fry accessors lisp.conses ; +combinators.lib math fry accessors lists ; IN: lisp.parser From e4b88c61f396d40d793e638860070429eb8baacc Mon Sep 17 00:00:00 2001 From: James Cash Date: Tue, 3 Jun 2008 04:04:20 -0400 Subject: [PATCH 19/71] Moving extra/lazy-lists to extra/lists/lazy --- extra/{lazy-lists => lists/lazy}/authors.txt | 0 .../lazy}/examples/authors.txt | 0 .../lazy}/examples/examples-tests.factor | 0 .../lazy}/examples/examples.factor | 0 .../lazy/lazy-docs.factor} | 42 +---------------- .../lazy/lazy-tests.factor} | 4 +- .../lazy/lazy.factor} | 2 +- extra/{lazy-lists => lists/lazy}/old-doc.html | 0 extra/{lazy-lists => lists/lazy}/summary.txt | 0 extra/{lazy-lists => lists/lazy}/tags.txt | 0 extra/lists/lists-docs.factor | 45 +++++++++++++++++++ 11 files changed, 49 insertions(+), 44 deletions(-) rename extra/{lazy-lists => lists/lazy}/authors.txt (100%) rename extra/{lazy-lists => lists/lazy}/examples/authors.txt (100%) rename extra/{lazy-lists => lists/lazy}/examples/examples-tests.factor (100%) rename extra/{lazy-lists => lists/lazy}/examples/examples.factor (100%) rename extra/{lazy-lists/lazy-lists-docs.factor => lists/lazy/lazy-docs.factor} (88%) rename extra/{lazy-lists/lazy-lists-tests.factor => lists/lazy/lazy-tests.factor} (90%) rename extra/{lazy-lists/lazy-lists.factor => lists/lazy/lazy.factor} (99%) rename extra/{lazy-lists => lists/lazy}/old-doc.html (100%) rename extra/{lazy-lists => lists/lazy}/summary.txt (100%) rename extra/{lazy-lists => lists/lazy}/tags.txt (100%) diff --git a/extra/lazy-lists/authors.txt b/extra/lists/lazy/authors.txt similarity index 100% rename from extra/lazy-lists/authors.txt rename to extra/lists/lazy/authors.txt diff --git a/extra/lazy-lists/examples/authors.txt b/extra/lists/lazy/examples/authors.txt similarity index 100% rename from extra/lazy-lists/examples/authors.txt rename to extra/lists/lazy/examples/authors.txt diff --git a/extra/lazy-lists/examples/examples-tests.factor b/extra/lists/lazy/examples/examples-tests.factor similarity index 100% rename from extra/lazy-lists/examples/examples-tests.factor rename to extra/lists/lazy/examples/examples-tests.factor diff --git a/extra/lazy-lists/examples/examples.factor b/extra/lists/lazy/examples/examples.factor similarity index 100% rename from extra/lazy-lists/examples/examples.factor rename to extra/lists/lazy/examples/examples.factor diff --git a/extra/lazy-lists/lazy-lists-docs.factor b/extra/lists/lazy/lazy-docs.factor similarity index 88% rename from extra/lazy-lists/lazy-lists-docs.factor rename to extra/lists/lazy/lazy-docs.factor index fb87bee10f..1de98971f6 100644 --- a/extra/lazy-lists/lazy-lists-docs.factor +++ b/extra/lists/lazy/lazy-docs.factor @@ -2,47 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: help.markup help.syntax sequences strings lists ; -IN: lazy-lists - -{ car cons cdr nil nil? list? uncons } related-words - -HELP: cons -{ $values { "car" "the head of the lazy list" } { "cdr" "the tail of the lazy list" } { "cons" "a cons object" } } -{ $description "Constructs a cons cell." } ; - -HELP: car -{ $values { "cons" "a cons object" } { "car" "the first item in the list" } } -{ $description "Returns the first item in the list." } ; - -HELP: cdr -{ $values { "cons" "a cons object" } { "cdr" "a cons object" } } -{ $description "Returns the tail of the list." } ; - -HELP: nil -{ $values { "cons" "An empty cons" } } -{ $description "Returns a representation of an empty list" } ; - -HELP: nil? -{ $values { "cons" "a cons object" } { "?" "a boolean" } } -{ $description "Return true if the cons object is the nil cons." } ; - -HELP: list? ( object -- ? ) -{ $values { "object" "an object" } { "?" "a boolean" } } -{ $description "Returns true if the object conforms to the list protocol." } ; - -{ 1list 2list 3list } related-words - -HELP: 1list -{ $values { "obj" "an object" } { "cons" "a cons object" } } -{ $description "Create a list with 1 element." } ; - -HELP: 2list -{ $values { "a" "an object" } { "b" "an object" } { "cons" "a cons object" } } -{ $description "Create a list with 2 elements." } ; - -HELP: 3list -{ $values { "a" "an object" } { "b" "an object" } { "c" "an object" } { "cons" "a cons object" } } -{ $description "Create a list with 3 elements." } ; +IN: lists.lazy HELP: lazy-cons { $values { "car" "a quotation with stack effect ( -- X )" } { "cdr" "a quotation with stack effect ( -- cons )" } { "promise" "the resulting cons object" } } diff --git a/extra/lazy-lists/lazy-lists-tests.factor b/extra/lists/lazy/lazy-tests.factor similarity index 90% rename from extra/lazy-lists/lazy-lists-tests.factor rename to extra/lists/lazy/lazy-tests.factor index 7dd0c0f009..f4bb7b595b 100644 --- a/extra/lazy-lists/lazy-lists-tests.factor +++ b/extra/lists/lazy/lazy-tests.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2006 Matthew Willis and Chris Double. ! See http://factorcode.org/license.txt for BSD license. ! -USING: lists lazy-lists tools.test kernel math io sequences ; -IN: lazy-lists.tests +USING: lists lists.lazy tools.test kernel math io sequences ; +IN: lists.lazy.tests [ { 1 2 3 4 } ] [ { 1 2 3 4 } >list list>array diff --git a/extra/lazy-lists/lazy-lists.factor b/extra/lists/lazy/lazy.factor similarity index 99% rename from extra/lazy-lists/lazy-lists.factor rename to extra/lists/lazy/lazy.factor index 8b3d069c40..f8b1a6e6ef 100644 --- a/extra/lazy-lists/lazy-lists.factor +++ b/extra/lists/lazy/lazy.factor @@ -7,7 +7,7 @@ ! USING: kernel sequences math vectors arrays namespaces quotations promises combinators io lists accessors ; -IN: lazy-lists +IN: lists.lazy M: promise car ( promise -- car ) force car ; diff --git a/extra/lazy-lists/old-doc.html b/extra/lists/lazy/old-doc.html similarity index 100% rename from extra/lazy-lists/old-doc.html rename to extra/lists/lazy/old-doc.html diff --git a/extra/lazy-lists/summary.txt b/extra/lists/lazy/summary.txt similarity index 100% rename from extra/lazy-lists/summary.txt rename to extra/lists/lazy/summary.txt diff --git a/extra/lazy-lists/tags.txt b/extra/lists/lazy/tags.txt similarity index 100% rename from extra/lazy-lists/tags.txt rename to extra/lists/lazy/tags.txt diff --git a/extra/lists/lists-docs.factor b/extra/lists/lists-docs.factor index e69de29bb2..94407765fc 100644 --- a/extra/lists/lists-docs.factor +++ b/extra/lists/lists-docs.factor @@ -0,0 +1,45 @@ +! Copyright (C) 2006 Chris Double. +! See http://factorcode.org/license.txt for BSD license. + +IN: lists +USING: help.markup help.syntax ; + +{ car cons cdr nil nil? list? uncons } related-words + +HELP: cons +{ $values { "car" "the head of the lazy list" } { "cdr" "the tail of the lazy list" } { "cons" "a cons object" } } +{ $description "Constructs a cons cell." } ; + +HELP: car +{ $values { "cons" "a cons object" } { "car" "the first item in the list" } } +{ $description "Returns the first item in the list." } ; + +HELP: cdr +{ $values { "cons" "a cons object" } { "cdr" "a cons object" } } +{ $description "Returns the tail of the list." } ; + +HELP: nil +{ $values { "cons" "An empty cons" } } +{ $description "Returns a representation of an empty list" } ; + +HELP: nil? +{ $values { "cons" "a cons object" } { "?" "a boolean" } } +{ $description "Return true if the cons object is the nil cons." } ; + +HELP: list? ( object -- ? ) +{ $values { "object" "an object" } { "?" "a boolean" } } +{ $description "Returns true if the object conforms to the list protocol." } ; + +{ 1list 2list 3list } related-words + +HELP: 1list +{ $values { "obj" "an object" } { "cons" "a cons object" } } +{ $description "Create a list with 1 element." } ; + +HELP: 2list +{ $values { "a" "an object" } { "b" "an object" } { "cons" "a cons object" } } +{ $description "Create a list with 2 elements." } ; + +HELP: 3list +{ $values { "a" "an object" } { "b" "an object" } { "c" "an object" } { "cons" "a cons object" } } +{ $description "Create a list with 3 elements." } ; \ No newline at end of file From 1818a743bd36902060686662a40e40c74b540322 Mon Sep 17 00:00:00 2001 From: James Cash Date: Tue, 3 Jun 2008 04:27:25 -0400 Subject: [PATCH 20/71] Updating libraries that uses lazy-lists to use lists/lazy --- extra/globs/globs.factor | 2 +- extra/json/reader/reader.factor | 2 +- extra/math/erato/erato-tests.factor | 2 +- extra/math/erato/erato.factor | 2 +- extra/math/primes/factors/factors.factor | 2 +- extra/math/primes/primes-tests.factor | 2 +- extra/math/primes/primes.factor | 2 +- extra/monads/monads-tests.factor | 2 +- extra/monads/monads.factor | 2 +- extra/morse/morse.factor | 2 +- extra/parser-combinators/parser-combinators-docs.factor | 2 +- extra/parser-combinators/parser-combinators-tests.factor | 2 +- extra/parser-combinators/parser-combinators.factor | 2 +- extra/parser-combinators/simple/simple-docs.factor | 8 ++++---- extra/parser-combinators/simple/simple.factor | 2 +- extra/project-euler/007/007.factor | 2 +- extra/project-euler/134/134.factor | 2 +- extra/regexp/regexp.factor | 2 +- extra/tetris/game/game.factor | 2 +- extra/tetris/piece/piece.factor | 2 +- 20 files changed, 23 insertions(+), 23 deletions(-) diff --git a/extra/globs/globs.factor b/extra/globs/globs.factor index 4fa56bcf93..db1921d86d 100755 --- a/extra/globs/globs.factor +++ b/extra/globs/globs.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: parser-combinators regexp lazy-lists sequences kernel +USING: parser-combinators regexp lists lists.lazy sequences kernel promises strings unicode.case ; IN: globs diff --git a/extra/json/reader/reader.factor b/extra/json/reader/reader.factor index 5e6b16dc2f..9d6155ea78 100755 --- a/extra/json/reader/reader.factor +++ b/extra/json/reader/reader.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel parser-combinators namespaces sequences promises strings assocs math math.parser math.vectors math.functions math.order - lazy-lists hashtables ascii ; + lists lists.lazy hashtables ascii ; IN: json.reader ! Grammar for JSON from RFC 4627 diff --git a/extra/math/erato/erato-tests.factor b/extra/math/erato/erato-tests.factor index 9244fa62e2..1f59659fa9 100644 --- a/extra/math/erato/erato-tests.factor +++ b/extra/math/erato/erato-tests.factor @@ -1,6 +1,6 @@ ! Copyright (c) 2007 Samuel Tardieu. ! See http://factorcode.org/license.txt for BSD license. -USING: lazy-lists math.erato tools.test ; +USING: lists lists.lazy math.erato tools.test ; IN: math.erato.tests [ { 2 3 5 7 11 13 17 19 } ] [ 20 lerato list>array ] unit-test diff --git a/extra/math/erato/erato.factor b/extra/math/erato/erato.factor index 40de92e3b1..292cec8def 100644 --- a/extra/math/erato/erato.factor +++ b/extra/math/erato/erato.factor @@ -1,6 +1,6 @@ ! Copyright (c) 2007 Samuel Tardieu. ! See http://factorcode.org/license.txt for BSD license. -USING: bit-arrays kernel lazy-lists math math.functions math.primes.list +USING: bit-arrays kernel lists lists.lazy math math.functions math.primes.list math.ranges sequences ; IN: math.erato diff --git a/extra/math/primes/factors/factors.factor b/extra/math/primes/factors/factors.factor index 2f70ab24b4..7413f9701b 100644 --- a/extra/math/primes/factors/factors.factor +++ b/extra/math/primes/factors/factors.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007 Samuel Tardieu. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel lazy-lists math math.primes namespaces sequences ; +USING: arrays kernel lists lists.lazy math math.primes namespaces sequences ; IN: math.primes.factors Date: Tue, 3 Jun 2008 04:41:36 -0400 Subject: [PATCH 21/71] Some files only need lists.lazy, not lists as well --- extra/math/erato/erato-tests.factor | 2 +- extra/math/erato/erato.factor | 2 +- extra/math/primes/primes-tests.factor | 2 +- extra/math/primes/primes.factor | 2 +- extra/parser-combinators/parser-combinators-tests.factor | 2 +- extra/parser-combinators/simple/simple.factor | 2 +- extra/project-euler/007/007.factor | 2 +- 7 files changed, 7 insertions(+), 7 deletions(-) diff --git a/extra/math/erato/erato-tests.factor b/extra/math/erato/erato-tests.factor index 1f59659fa9..041cb8dc3a 100644 --- a/extra/math/erato/erato-tests.factor +++ b/extra/math/erato/erato-tests.factor @@ -1,6 +1,6 @@ ! Copyright (c) 2007 Samuel Tardieu. ! See http://factorcode.org/license.txt for BSD license. -USING: lists lists.lazy math.erato tools.test ; +USING: lists.lazy math.erato tools.test ; IN: math.erato.tests [ { 2 3 5 7 11 13 17 19 } ] [ 20 lerato list>array ] unit-test diff --git a/extra/math/erato/erato.factor b/extra/math/erato/erato.factor index 292cec8def..b9d997c038 100644 --- a/extra/math/erato/erato.factor +++ b/extra/math/erato/erato.factor @@ -1,6 +1,6 @@ ! Copyright (c) 2007 Samuel Tardieu. ! See http://factorcode.org/license.txt for BSD license. -USING: bit-arrays kernel lists lists.lazy math math.functions math.primes.list +USING: bit-arrays kernel lists.lazy math math.functions math.primes.list math.ranges sequences ; IN: math.erato diff --git a/extra/math/primes/primes-tests.factor b/extra/math/primes/primes-tests.factor index 2db98af893..186acc9b11 100644 --- a/extra/math/primes/primes-tests.factor +++ b/extra/math/primes/primes-tests.factor @@ -1,4 +1,4 @@ -USING: arrays math.primes tools.test lists lists.lazy ; +USING: arrays math.primes tools.test lists.lazy ; { 1237 } [ 1234 next-prime ] unit-test { f t } [ 1234 prime? 1237 prime? ] unit-test diff --git a/extra/math/primes/primes.factor b/extra/math/primes/primes.factor index e42bb8d82d..59aebbf0dd 100644 --- a/extra/math/primes/primes.factor +++ b/extra/math/primes/primes.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007 Samuel Tardieu. ! See http://factorcode.org/license.txt for BSD license. -USING: combinators kernel lists lists.lazy math math.functions math.miller-rabin +USING: combinators kernel lists.lazy math math.functions math.miller-rabin math.order math.primes.list math.ranges sequences sorting ; IN: math.primes diff --git a/extra/parser-combinators/parser-combinators-tests.factor b/extra/parser-combinators/parser-combinators-tests.factor index 062277ec4d..70698daa0b 100755 --- a/extra/parser-combinators/parser-combinators-tests.factor +++ b/extra/parser-combinators/parser-combinators-tests.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2005 Chris Double. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel lists lists.lazy tools.test strings math +USING: kernel lists.lazy tools.test strings math sequences parser-combinators arrays math.parser unicode.categories ; IN: parser-combinators.tests diff --git a/extra/parser-combinators/simple/simple.factor b/extra/parser-combinators/simple/simple.factor index 5182260e98..f7a696ca35 100755 --- a/extra/parser-combinators/simple/simple.factor +++ b/extra/parser-combinators/simple/simple.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006 Chris Double. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel strings math sequences lists lists.lazy words +USING: kernel strings math sequences lists.lazy words math.parser promises parser-combinators unicode.categories ; IN: parser-combinators.simple diff --git a/extra/project-euler/007/007.factor b/extra/project-euler/007/007.factor index 10e95bd2b5..40178c4291 100644 --- a/extra/project-euler/007/007.factor +++ b/extra/project-euler/007/007.factor @@ -1,6 +1,6 @@ ! Copyright (c) 2007 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: lists lists.lazy math math.primes ; +USING: lists.lazy math math.primes ; IN: project-euler.007 ! http://projecteuler.net/index.php?section=problems&id=7 From 1bd222228c95753fa3e5f18f6eb5d21a13b31790 Mon Sep 17 00:00:00 2001 From: James Cash Date: Tue, 3 Jun 2008 05:06:52 -0400 Subject: [PATCH 22/71] Making sure that vocabs only have lists or lists.lazy if they need them --- extra/json/reader/reader.factor | 2 +- extra/math/primes/factors/factors.factor | 2 +- extra/monads/monads-tests.factor | 2 +- extra/morse/morse.factor | 2 +- extra/parser-combinators/parser-combinators-docs.factor | 2 +- extra/parser-combinators/simple/simple-docs.factor | 8 ++++---- extra/regexp/regexp.factor | 2 +- extra/tetris/game/game.factor | 2 +- extra/tetris/piece/piece.factor | 2 +- 9 files changed, 12 insertions(+), 12 deletions(-) diff --git a/extra/json/reader/reader.factor b/extra/json/reader/reader.factor index 9d6155ea78..6bd6905804 100755 --- a/extra/json/reader/reader.factor +++ b/extra/json/reader/reader.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel parser-combinators namespaces sequences promises strings assocs math math.parser math.vectors math.functions math.order - lists lists.lazy hashtables ascii ; + lists hashtables ascii ; IN: json.reader ! Grammar for JSON from RFC 4627 diff --git a/extra/math/primes/factors/factors.factor b/extra/math/primes/factors/factors.factor index 7413f9701b..b38a7926d2 100644 --- a/extra/math/primes/factors/factors.factor +++ b/extra/math/primes/factors/factors.factor @@ -17,7 +17,7 @@ IN: math.primes.factors dup empty? [ drop ] [ first , ] if ; : (factors) ( quot list n -- ) - dup 1 > [ swap uncons >r pick call r> swap (factors) ] [ 3drop ] if ; + dup 1 > [ swap uncons swap >r pick call r> swap (factors) ] [ 3drop ] if ; : (decompose) ( n quot -- seq ) [ lprimes rot (factors) ] { } make ; diff --git a/extra/monads/monads-tests.factor b/extra/monads/monads-tests.factor index 98cc403910..d0014b5abe 100644 --- a/extra/monads/monads-tests.factor +++ b/extra/monads/monads-tests.factor @@ -1,4 +1,4 @@ -USING: tools.test monads math kernel sequences lists lists.lazy promises ; +USING: tools.test monads math kernel sequences lists promises ; IN: monads.tests [ 5 ] [ 1 identity-monad return [ 4 + ] fmap run-identity ] unit-test diff --git a/extra/morse/morse.factor b/extra/morse/morse.factor index 71b7249351..591915b317 100644 --- a/extra/morse/morse.factor +++ b/extra/morse/morse.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007, 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs combinators hashtables kernel lists lists.lazy math namespaces openal parser-combinators promises sequences strings symbols synth synth.buffers unicode.case ; +USING: accessors assocs combinators hashtables kernel lists math namespaces openal parser-combinators promises sequences strings symbols synth synth.buffers unicode.case ; IN: morse Date: Tue, 3 Jun 2008 05:18:36 -0400 Subject: [PATCH 23/71] Fix for changed effect of uncons --- extra/project-euler/134/134.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/project-euler/134/134.factor b/extra/project-euler/134/134.factor index ddba76d5a0..4e54a18f19 100644 --- a/extra/project-euler/134/134.factor +++ b/extra/project-euler/134/134.factor @@ -39,7 +39,7 @@ IN: project-euler.134 PRIVATE> : euler134 ( -- answer ) - 0 5 lprimes-from uncons [ 1000000 > ] luntil + 0 5 lprimes-from uncons swap [ 1000000 > ] luntil [ [ s + ] keep ] leach drop ; ! [ euler134 ] 10 ave-time From 707226859a945656ead5d161719ca1106343145b Mon Sep 17 00:00:00 2001 From: James Cash Date: Tue, 3 Jun 2008 16:28:02 -0400 Subject: [PATCH 24/71] Renaming map-cons to lmap and lmap to lazy-map --- extra/lists/lazy/lazy-docs.factor | 2 ++ extra/lists/lazy/lazy.factor | 31 ++++++----------------- extra/lists/lists-docs.factor | 26 ++++++++++++++++++-- extra/lists/lists.factor | 41 ++++++++++++++++++++++--------- extra/monads/monads.factor | 2 +- 5 files changed, 64 insertions(+), 38 deletions(-) diff --git a/extra/lists/lazy/lazy-docs.factor b/extra/lists/lazy/lazy-docs.factor index 1de98971f6..0e6c93766d 100644 --- a/extra/lists/lazy/lazy-docs.factor +++ b/extra/lists/lazy/lazy-docs.factor @@ -107,6 +107,8 @@ HELP: >list { $values { "object" "an object" } { "list" "a list" } } { $description "Convert the object into a list. Existing lists are passed through intact, sequences are converted using " { $link seq>list } " and other objects cause an error to be thrown." } { $see-also seq>list } ; + +{ leach lreduce lmap lmap-with ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lreduce lwhile luntil } related-words HELP: lconcat { $values { "list" "a list of lists" } { "result" "a list" } } diff --git a/extra/lists/lazy/lazy.factor b/extra/lists/lazy/lazy.factor index f8b1a6e6ef..7ab5bbb84e 100644 --- a/extra/lists/lazy/lazy.factor +++ b/extra/lists/lazy/lazy.factor @@ -44,21 +44,6 @@ M: lazy-cons nil? ( lazy-cons -- bool ) : 3lazy-list ( a b c -- lazy-cons ) 2lazy-list 1quotation lazy-cons ; -: lnth ( n list -- elt ) - swap [ cdr ] times car ; - -: (llength) ( list acc -- n ) - over nil? [ nip ] [ [ cdr ] dip 1+ (llength) ] if ; - -: llength ( list -- n ) - 0 (llength) ; - -: leach ( list quot -- ) - over nil? [ 2drop ] [ [ uncons ] dip tuck call leach ] if ; inline - -: lreduce ( list identity quot -- result ) - swapd leach ; inline - TUPLE: memoized-cons original car cdr nil? ; : not-memoized ( -- obj ) @@ -96,7 +81,7 @@ TUPLE: lazy-map cons quot ; C: lazy-map -: lmap ( list quot -- result ) +: lazy-map ( list quot -- result ) over nil? [ 2drop nil ] [ ] if ; M: lazy-map car ( lazy-map -- car ) @@ -105,13 +90,13 @@ M: lazy-map car ( lazy-map -- car ) M: lazy-map cdr ( lazy-map -- cdr ) [ cons>> cdr ] keep - quot>> lmap ; + quot>> lazy-map ; M: lazy-map nil? ( lazy-map -- bool ) cons>> nil? ; -: lmap-with ( value list quot -- result ) - with lmap ; +: lazy-map-with ( value list quot -- result ) + with lazy-map ; TUPLE: lazy-take n cons ; @@ -323,22 +308,22 @@ M: lazy-concat nil? ( lazy-concat -- bool ) ] if ; : lcartesian-product ( list1 list2 -- result ) - swap [ swap [ 2array ] lmap-with ] lmap-with lconcat ; + swap [ swap [ 2array ] lazy-map-with ] lazy-map-with lconcat ; : lcartesian-product* ( lists -- result ) dup nil? [ drop nil ] [ [ car ] keep cdr [ car lcartesian-product ] keep cdr list>array swap [ - swap [ swap [ suffix ] lmap-with ] lmap-with lconcat + swap [ swap [ suffix ] lazy-map-with ] lazy-map-with lconcat ] reduce ] if ; : lcomp ( list quot -- result ) - [ lcartesian-product* ] dip lmap ; + [ lcartesian-product* ] dip lazy-map ; : lcomp* ( list guards quot -- result ) - [ [ lcartesian-product* ] dip [ lfilter ] each ] dip lmap ; + [ [ lcartesian-product* ] dip [ lfilter ] each ] dip lazy-map ; DEFER: lmerge diff --git a/extra/lists/lists-docs.factor b/extra/lists/lists-docs.factor index 94407765fc..8a691cd4e2 100644 --- a/extra/lists/lists-docs.factor +++ b/extra/lists/lists-docs.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2006 Chris Double. ! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax ; IN: lists -USING: help.markup help.syntax ; { car cons cdr nil nil? list? uncons } related-words @@ -42,4 +42,26 @@ HELP: 2list HELP: 3list { $values { "a" "an object" } { "b" "an object" } { "c" "an object" } { "cons" "a cons object" } } -{ $description "Create a list with 3 elements." } ; \ No newline at end of file +{ $description "Create a list with 3 elements." } ; + +HELP: lnth +{ $values { "n" "an integer index" } { "list" "a cons object" } { "elt" "the element at the nth index" } } +{ $description "Outputs the nth element of the list." } +{ $see-also llength cons car cdr } ; + +HELP: llength +{ $values { "list" "a cons object" } { "n" "a non-negative integer" } } +{ $description "Outputs the length of the list. This should not be called on an infinite list." } +{ $see-also lnth cons car cdr } ; + +HELP: uncons +{ $values { "cons" "a cons object" } { "car" "the head of the list" } { "cdr" "the tail of the list" } } +{ $description "Put the head and tail of the list on the stack." } ; + +HELP: leach +{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( obj -- )" } } +{ $description "Call the quotation for each item in the list." } ; + +HELP: lreduce +{ $values { "list" "a cons object" } { "identity" "an object" } { "quot" "a quotation with stack effect ( prev elt -- next )" } { "result" "the final result" } } +{ $description "Combines successive elements of the list using a binary operation, and outputs the final result." } ; diff --git a/extra/lists/lists.factor b/extra/lists/lists.factor index 4b8cc77658..d9af80a2bc 100644 --- a/extra/lists/lists.factor +++ b/extra/lists/lists.factor @@ -1,10 +1,10 @@ -! Copyright (C) 2008 James Cash +! Copyright (C) 2008 Chris Double & James Cash ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences accessors ; +USING: kernel sequences accessors math ; IN: lists -! Lazy List Protocol +! List Protocol MIXIN: list GENERIC: car ( cons -- car ) GENERIC: cdr ( cons -- cdr ) @@ -28,31 +28,48 @@ M: cons nil? ( cons -- bool ) : 1list ( obj -- cons ) nil cons ; - + : 2list ( a b -- cons ) nil cons cons ; : 3list ( a b c -- cons ) nil cons cons cons ; +: 2car ( cons -- car caar ) + [ car ] [ cdr car ] bi ; + +: 3car ( cons -- car caar caaar ) + [ car ] [ cdr car ] [ cdr cdr car ] tri ; + : uncons ( cons -- cdr car ) [ cdr ] [ car ] bi ; +: lnth ( n list -- elt ) + swap [ cdr ] times car ; + +: (llength) ( list acc -- n ) + over nil? [ nip ] [ [ cdr ] dip 1+ (llength) ] if ; + +: llength ( list -- n ) + 0 (llength) ; + +: leach ( list quot -- ) + over nil? [ 2drop ] [ [ uncons ] dip tuck call leach ] if ; inline + +: lreduce ( list identity quot -- result ) + swapd leach ; inline + : seq>cons ( seq -- cons ) nil [ f cons swap >>cdr ] reduce ; -: (map-cons) ( acc cons quot -- seq ) +: (lmap) ( acc cons quot -- seq ) over nil? [ 2drop ] - [ [ uncons ] dip [ call ] keep swapd [ suffix ] 2dip (map-cons) ] if ; + [ [ uncons ] dip [ call ] keep swapd [ suffix ] 2dip (map-cons) ] if ; inline -: map-cons ( cons quot -- seq ) - [ { } clone ] 2dip (map-cons) ; +: lmap ( cons quot -- seq ) + [ { } clone ] 2dip (map-cons) ; inline : cons>seq ( cons -- array ) [ ] map-cons ; -: reduce-cons ( cons identity quot -- result ) - pick nil? [ drop nip ] - [ [ uncons ] 2dip swapd [ call ] keep reduce-cons ] if ; - INSTANCE: cons list \ No newline at end of file diff --git a/extra/monads/monads.factor b/extra/monads/monads.factor index 18820d1b53..c1ab4400ba 100644 --- a/extra/monads/monads.factor +++ b/extra/monads/monads.factor @@ -124,7 +124,7 @@ M: list-monad fail 2drop nil ; M: list monad-of drop list-monad ; -M: list >>= '[ , _ lmap lconcat ] ; +M: list >>= '[ , _ lazy-map lconcat ] ; ! State SINGLETON: state-monad From 53daf5504a5e2faec4afc21e415d058370c3a546 Mon Sep 17 00:00:00 2001 From: James Cash Date: Tue, 3 Jun 2008 16:31:38 -0400 Subject: [PATCH 25/71] Reorganizing docs for lists and lists.lazy to reflect words moving between the vocabs --- extra/lists/lazy/lazy-docs.factor | 26 ++------------------------ extra/lists/lists-docs.factor | 15 +++++++++++++++ 2 files changed, 17 insertions(+), 24 deletions(-) diff --git a/extra/lists/lazy/lazy-docs.factor b/extra/lists/lazy/lazy-docs.factor index 0e6c93766d..f410b99317 100644 --- a/extra/lists/lazy/lazy-docs.factor +++ b/extra/lists/lazy/lazy-docs.factor @@ -28,31 +28,9 @@ HELP: { $description "Constructs a cons object that wraps an existing cons object. Requests for the car, cdr and nil? will be remembered after the first call, and the previous result returned on subsequent calls." } { $see-also cons car cdr nil nil? } ; -HELP: lnth -{ $values { "n" "an integer index" } { "list" "a cons object" } { "elt" "the element at the nth index" } } -{ $description "Outputs the nth element of the list." } -{ $see-also llength cons car cdr } ; +{ lazy-map lazy-map-with ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lwhile luntil } related-words -HELP: llength -{ $values { "list" "a cons object" } { "n" "a non-negative integer" } } -{ $description "Outputs the length of the list. This should not be called on an infinite list." } -{ $see-also lnth cons car cdr } ; - -HELP: uncons -{ $values { "cons" "a cons object" } { "car" "the head of the list" } { "cdr" "the tail of the list" } } -{ $description "Put the head and tail of the list on the stack." } ; - -{ leach lreduce lmap lmap-with ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lreduce lwhile luntil } related-words - -HELP: leach -{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( obj -- )" } } -{ $description "Call the quotation for each item in the list." } ; - -HELP: lreduce -{ $values { "list" "a cons object" } { "identity" "an object" } { "quot" "a quotation with stack effect ( prev elt -- next )" } { "result" "the final result" } } -{ $description "Combines successive elements of the list using a binary operation, and outputs the final result." } ; - -HELP: lmap +HELP: lazy-map { $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( obj -- X )" } { "result" "resulting cons object" } } { $description "Perform a similar functionality to that of the " { $link map } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ; diff --git a/extra/lists/lists-docs.factor b/extra/lists/lists-docs.factor index 8a691cd4e2..1e5a5fd396 100644 --- a/extra/lists/lists-docs.factor +++ b/extra/lists/lists-docs.factor @@ -65,3 +65,18 @@ HELP: leach HELP: lreduce { $values { "list" "a cons object" } { "identity" "an object" } { "quot" "a quotation with stack effect ( prev elt -- next )" } { "result" "the final result" } } { $description "Combines successive elements of the list using a binary operation, and outputs the final result." } ; + +HELP: uncons +{ $values { "cons" "a cons object" } { "car" "the head of the list" } { "cdr" "the tail of the list" } } +{ $description "Put the head and tail of the list on the stack." } ; + +{ leach lreduce lmap } related-words + +HELP: leach +{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( obj -- )" } } +{ $description "Call the quotation for each item in the list." } ; + +HELP: lreduce +{ $values { "list" "a cons object" } { "identity" "an object" } { "quot" "a quotation with stack effect ( prev elt -- next )" } { "result" "the final result" } } +{ $description "Combines successive elements of the list using a binary operation, and outputs the final result." } ; + From 0ca627051ea6d5bef5b1d18713653ee38bad2c8b Mon Sep 17 00:00:00 2001 From: James Cash Date: Tue, 3 Jun 2008 16:57:29 -0400 Subject: [PATCH 26/71] Changing vocabs USING: to reflect which words are in lists and lists.lazy --- extra/globs/globs.factor | 2 +- extra/lists/lazy/examples/examples.factor | 2 +- extra/lists/lazy/lazy-docs.factor | 6 +++--- extra/lists/lazy/lazy-tests.factor | 2 +- extra/lists/lists-tests.factor | 4 ++-- extra/math/primes/factors/factors.factor | 2 +- extra/parser-combinators/parser-combinators.factor | 8 ++++---- extra/project-euler/007/007.factor | 2 +- 8 files changed, 14 insertions(+), 14 deletions(-) diff --git a/extra/globs/globs.factor b/extra/globs/globs.factor index db1921d86d..d131946ffb 100755 --- a/extra/globs/globs.factor +++ b/extra/globs/globs.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: parser-combinators regexp lists lists.lazy sequences kernel +USING: parser-combinators regexp lists sequences kernel promises strings unicode.case ; IN: globs diff --git a/extra/lists/lazy/examples/examples.factor b/extra/lists/lazy/examples/examples.factor index 844ae31085..9e8fb77439 100644 --- a/extra/lists/lazy/examples/examples.factor +++ b/extra/lists/lazy/examples/examples.factor @@ -11,5 +11,5 @@ IN: lazy-lists.examples : odds 1 lfrom [ 2 mod 1 = ] lfilter ; : powers-of-2 1 [ 2 * ] lfrom-by ; : ones 1 [ ] lfrom-by ; -: squares naturals [ dup * ] lmap ; +: squares naturals [ dup * ] lazy-map ; : first-five-squares 5 squares ltake list>array ; diff --git a/extra/lists/lazy/lazy-docs.factor b/extra/lists/lazy/lazy-docs.factor index f410b99317..f2b03fe108 100644 --- a/extra/lists/lazy/lazy-docs.factor +++ b/extra/lists/lazy/lazy-docs.factor @@ -34,9 +34,9 @@ HELP: lazy-map { $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( obj -- X )" } { "result" "resulting cons object" } } { $description "Perform a similar functionality to that of the " { $link map } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ; -HELP: lmap-with +HELP: lazy-map-with { $values { "value" "an object" } { "list" "a cons object" } { "quot" "a quotation with stack effect ( obj elt -- X )" } { "result" "resulting cons object" } } -{ $description "Variant of " { $link lmap } " which pushes a retained object on each invocation of the quotation." } ; +{ $description "Variant of " { $link lazy-map } " which pushes a retained object on each invocation of the quotation." } ; HELP: ltake { $values { "n" "a non negative integer" } { "list" "a cons object" } { "result" "resulting cons object" } } @@ -86,7 +86,7 @@ HELP: >list { $description "Convert the object into a list. Existing lists are passed through intact, sequences are converted using " { $link seq>list } " and other objects cause an error to be thrown." } { $see-also seq>list } ; -{ leach lreduce lmap lmap-with ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lreduce lwhile luntil } related-words +{ leach lreduce lazy-map lazy-map-with ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lreduce lwhile luntil } related-words HELP: lconcat { $values { "list" "a list of lists" } { "result" "a list" } } diff --git a/extra/lists/lazy/lazy-tests.factor b/extra/lists/lazy/lazy-tests.factor index f4bb7b595b..5749f94364 100644 --- a/extra/lists/lazy/lazy-tests.factor +++ b/extra/lists/lazy/lazy-tests.factor @@ -25,5 +25,5 @@ IN: lists.lazy.tests ] unit-test [ { 4 5 6 } ] [ - 3 { 1 2 3 } >list [ + ] lmap-with list>array + 3 { 1 2 3 } >list [ + ] lazy-map-with list>array ] unit-test diff --git a/extra/lists/lists-tests.factor b/extra/lists/lists-tests.factor index 41f2d1d356..718b4bff4e 100644 --- a/extra/lists/lists-tests.factor +++ b/extra/lists/lists-tests.factor @@ -9,7 +9,7 @@ IN: lists.tests T{ cons f 2 T{ cons f 3 T{ cons f 4 - T{ cons f f f } } } } } [ 2 + ] map-cons + T{ cons f f f } } } } } [ 2 + ] lmap ] unit-test { 10 } [ @@ -17,5 +17,5 @@ IN: lists.tests T{ cons f 2 T{ cons f 3 T{ cons f 4 - T{ cons f f f } } } } } 0 [ + ] reduce-cons + T{ cons f f f } } } } } 0 [ + ] lreduce ] unit-test \ No newline at end of file diff --git a/extra/math/primes/factors/factors.factor b/extra/math/primes/factors/factors.factor index b38a7926d2..aba7e90bc9 100644 --- a/extra/math/primes/factors/factors.factor +++ b/extra/math/primes/factors/factors.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007 Samuel Tardieu. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel lists lists.lazy math math.primes namespaces sequences ; +USING: arrays kernel lists math math.primes namespaces sequences ; IN: math.primes.factors r parse-result-parsed r> [ parse-result-parsed 2array ] keep parse-result-unparsed - ] lmap-with - ] lmap-with lconcat ; + ] lazy-map-with + ] lazy-map-with lconcat ; M: and-parser parse ( input parser -- list ) #! Parse 'input' by sequentially combining the @@ -171,7 +171,7 @@ M: or-parser parse ( input parser1 -- list ) #! of parser1 and parser2 being applied to the same #! input. This implements the choice parsing operator. or-parser-parsers 0 swap seq>list - [ parse ] lmap-with lconcat ; + [ parse ] lazy-map-with lconcat ; : left-trim-slice ( string -- string ) #! Return a new string without any leading whitespace @@ -216,7 +216,7 @@ M: apply-parser parse ( input parser -- result ) -rot parse [ [ parse-result-parsed swap call ] keep parse-result-unparsed - ] lmap-with ; + ] lazy-map-with ; TUPLE: some-parser p1 ; diff --git a/extra/project-euler/007/007.factor b/extra/project-euler/007/007.factor index 40178c4291..04686a8328 100644 --- a/extra/project-euler/007/007.factor +++ b/extra/project-euler/007/007.factor @@ -1,6 +1,6 @@ ! Copyright (c) 2007 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: lists.lazy math math.primes ; +USING: lists math math.primes ; IN: project-euler.007 ! http://projecteuler.net/index.php?section=problems&id=7 From b5405f69ae8e48c7495cddff6348bf9819929f3b Mon Sep 17 00:00:00 2001 From: James Cash Date: Tue, 3 Jun 2008 20:11:03 -0400 Subject: [PATCH 27/71] adding map-as, fixing seq>cons --- extra/lists/lists.factor | 22 ++++++++++++++-------- 1 file changed, 14 insertions(+), 8 deletions(-) diff --git a/extra/lists/lists.factor b/extra/lists/lists.factor index d9af80a2bc..0af026edd1 100644 --- a/extra/lists/lists.factor +++ b/extra/lists/lists.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Chris Double & James Cash ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences accessors math ; +USING: kernel sequences accessors math arrays vectors classes ; IN: lists @@ -55,21 +55,27 @@ M: cons nil? ( cons -- bool ) : leach ( list quot -- ) over nil? [ 2drop ] [ [ uncons ] dip tuck call leach ] if ; inline - + : lreduce ( list identity quot -- result ) swapd leach ; inline -: seq>cons ( seq -- cons ) - nil [ f cons swap >>cdr ] reduce ; - : (lmap) ( acc cons quot -- seq ) over nil? [ 2drop ] - [ [ uncons ] dip [ call ] keep swapd [ suffix ] 2dip (map-cons) ] if ; inline + [ [ uncons ] dip [ call ] keep swapd [ suffix ] 2dip (lmap) ] if ; inline : lmap ( cons quot -- seq ) - [ { } clone ] 2dip (map-cons) ; inline + [ { } clone ] 2dip (lmap) ; inline + +: lmap-as ( cons quot exemplar -- seq ) + [ lmap ] dip like ; + +: same? ( obj1 obj2 -- ? ) + [ class ] bi@ = ; + +: seq>cons ( seq -- cons ) + [ ] keep nil [ tuck same? [ seq>cons ] when f cons swap >>cdr ] with reduce ; : cons>seq ( cons -- array ) - [ ] map-cons ; + [ ] lmap ; INSTANCE: cons list \ No newline at end of file From b3808a08d5cc83cf4e685dfc5e89f3790efeae3b Mon Sep 17 00:00:00 2001 From: James Cash Date: Tue, 3 Jun 2008 20:11:27 -0400 Subject: [PATCH 28/71] Removing duplicate entries in lists-docs --- extra/lists/lists-docs.factor | 12 ------------ 1 file changed, 12 deletions(-) diff --git a/extra/lists/lists-docs.factor b/extra/lists/lists-docs.factor index 1e5a5fd396..4fae52f5b4 100644 --- a/extra/lists/lists-docs.factor +++ b/extra/lists/lists-docs.factor @@ -58,18 +58,6 @@ HELP: uncons { $values { "cons" "a cons object" } { "car" "the head of the list" } { "cdr" "the tail of the list" } } { $description "Put the head and tail of the list on the stack." } ; -HELP: leach -{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( obj -- )" } } -{ $description "Call the quotation for each item in the list." } ; - -HELP: lreduce -{ $values { "list" "a cons object" } { "identity" "an object" } { "quot" "a quotation with stack effect ( prev elt -- next )" } { "result" "the final result" } } -{ $description "Combines successive elements of the list using a binary operation, and outputs the final result." } ; - -HELP: uncons -{ $values { "cons" "a cons object" } { "car" "the head of the list" } { "cdr" "the tail of the list" } } -{ $description "Put the head and tail of the list on the stack." } ; - { leach lreduce lmap } related-words HELP: leach From 65f9fd92315ad53f7ffa44bfd46c18d555e6678e Mon Sep 17 00:00:00 2001 From: James Cash Date: Tue, 3 Jun 2008 20:11:45 -0400 Subject: [PATCH 29/71] Adding more tests for lists --- extra/lists/lists-tests.factor | 27 ++++++++++++++++++++++++--- 1 file changed, 24 insertions(+), 3 deletions(-) diff --git a/extra/lists/lists-tests.factor b/extra/lists/lists-tests.factor index 718b4bff4e..8e78872a52 100644 --- a/extra/lists/lists-tests.factor +++ b/extra/lists/lists-tests.factor @@ -9,13 +9,34 @@ IN: lists.tests T{ cons f 2 T{ cons f 3 T{ cons f 4 - T{ cons f f f } } } } } [ 2 + ] lmap + nil } } } } [ 2 + ] lmap ] unit-test { 10 } [ - T{ cons f 1 + T{ cons f 1 T{ cons f 2 T{ cons f 3 T{ cons f 4 - T{ cons f f f } } } } } 0 [ + ] lreduce + nil } } } } 0 [ + ] lreduce +] unit-test + +T{ + cons + f + 1 + T{ + cons + f + 2 + T{ + cons + f + T{ cons f 3 T{ cons f 4 T{ cons f 5 nil } } } + T{ cons f f f } + } } } [ + { 1 2 { 3 4 { 5 } } } seq>cons +] unit-test + +{ { 1 2 { 3 4 { 5 } } } } [ + { 1 2 { 3 4 { 5 } } } seq>cons cons>seq ] unit-test \ No newline at end of file From ed0468b8f520d4d0f568e3ca3f01fe985ab77bef Mon Sep 17 00:00:00 2001 From: James Cash Date: Tue, 3 Jun 2008 23:38:56 -0400 Subject: [PATCH 30/71] Fixing typo in lists-tests --- extra/lists/lists-tests.factor | 32 ++++++++++++++++---------------- 1 file changed, 16 insertions(+), 16 deletions(-) diff --git a/extra/lists/lists-tests.factor b/extra/lists/lists-tests.factor index 8e78872a52..16bc65ebb3 100644 --- a/extra/lists/lists-tests.factor +++ b/extra/lists/lists-tests.factor @@ -9,7 +9,7 @@ IN: lists.tests T{ cons f 2 T{ cons f 3 T{ cons f 4 - nil } } } } [ 2 + ] lmap + T{ cons f f f } } } } } [ 2 + ] lmap ] unit-test { 10 } [ @@ -17,23 +17,23 @@ IN: lists.tests T{ cons f 2 T{ cons f 3 T{ cons f 4 - nil } } } } 0 [ + ] lreduce + T{ cons f f f } } } } } 0 [ + ] lreduce ] unit-test -T{ - cons - f - 1 - T{ - cons - f - 2 - T{ - cons - f - T{ cons f 3 T{ cons f 4 T{ cons f 5 nil } } } - T{ cons f f f } - } } } [ +{ T{ cons f + 1 + T{ cons f + 2 + T{ cons f + T{ cons f + 3 + T{ cons f + 4 + T{ cons f + T{ cons f 5 T{ cons f f f } } + T{ cons f f f } } } } + T{ cons f f f } } } } +} [ { 1 2 { 3 4 { 5 } } } seq>cons ] unit-test From f63e6f1e35a7332fb50385c74c3157f28cfcfbfc Mon Sep 17 00:00:00 2001 From: James Cash Date: Tue, 3 Jun 2008 23:39:45 -0400 Subject: [PATCH 31/71] Fixing some bugs/oddities in lists implementations --- extra/lists/lists.factor | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/extra/lists/lists.factor b/extra/lists/lists.factor index 0af026edd1..b7e5e6523f 100644 --- a/extra/lists/lists.factor +++ b/extra/lists/lists.factor @@ -22,10 +22,13 @@ M: cons cdr ( cons -- cdr ) : nil ( -- cons ) T{ cons f f f } ; + +: uncons ( cons -- cdr car ) + [ cdr ] [ car ] bi ; -M: cons nil? ( cons -- bool ) - nil eq? ; - +M: cons nil? ( cons -- ? ) + uncons and not ; + : 1list ( obj -- cons ) nil cons ; @@ -40,9 +43,6 @@ M: cons nil? ( cons -- bool ) : 3car ( cons -- car caar caaar ) [ car ] [ cdr car ] [ cdr cdr car ] tri ; - -: uncons ( cons -- cdr car ) - [ cdr ] [ car ] bi ; : lnth ( n list -- elt ) swap [ cdr ] times car ; @@ -57,14 +57,15 @@ M: cons nil? ( cons -- bool ) over nil? [ 2drop ] [ [ uncons ] dip tuck call leach ] if ; inline : lreduce ( list identity quot -- result ) - swapd leach ; inline + pick nil? [ drop nip ] + [ [ uncons ] 2dip swapd [ call ] keep lreduce ] if ; inline : (lmap) ( acc cons quot -- seq ) over nil? [ 2drop ] [ [ uncons ] dip [ call ] keep swapd [ suffix ] 2dip (lmap) ] if ; inline : lmap ( cons quot -- seq ) - [ { } clone ] 2dip (lmap) ; inline + { } -rot (lmap) ; inline : lmap-as ( cons quot exemplar -- seq ) [ lmap ] dip like ; @@ -76,6 +77,6 @@ M: cons nil? ( cons -- bool ) [ ] keep nil [ tuck same? [ seq>cons ] when f cons swap >>cdr ] with reduce ; : cons>seq ( cons -- array ) - [ ] lmap ; + [ dup cons? [ cons>seq ] when ] lmap ; INSTANCE: cons list \ No newline at end of file From 138fff1c2b9404e2d148780cc93f96424d1afbf2 Mon Sep 17 00:00:00 2001 From: James Cash Date: Tue, 3 Jun 2008 23:40:30 -0400 Subject: [PATCH 32/71] Temporarily removing test for 'list' in lisp-tests, while switching to cons cells --- extra/lisp/lisp-tests.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/extra/lisp/lisp-tests.factor b/extra/lisp/lisp-tests.factor index 2358fa3f7e..2603a75cb0 100644 --- a/extra/lisp/lisp-tests.factor +++ b/extra/lisp/lisp-tests.factor @@ -13,7 +13,7 @@ IN: lisp.test "+" "math" "+" define-primitive "-" "math" "-" define-primitive - "list" [ >array ] lisp-define +! "list" [ >array ] lisp-define { 5 } [ [ 2 3 ] "+" funcall @@ -47,8 +47,8 @@ IN: lisp.test "((lambda (x) (if x (begin (+ 1 2)) (- 3 5))) #t)" lisp-eval ] unit-test - { { 1 2 3 4 5 } } [ - "(list 1 2 3 4 5)" lisp-eval - ] unit-test +! { { 1 2 3 4 5 } } [ +! "(list 1 2 3 4 5)" lisp-eval +! ] unit-test ] with-interactive-vocabs From 09d11546415d78912a2054722bef1fada8acc000 Mon Sep 17 00:00:00 2001 From: James Cash Date: Tue, 3 Jun 2008 23:41:05 -0400 Subject: [PATCH 33/71] Lisp now passes all tests using conses --- extra/lisp/lisp.factor | 45 ++++++++++++++++++++++++++---------------- 1 file changed, 28 insertions(+), 17 deletions(-) diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor index b034619d0d..fdcea0eca1 100644 --- a/extra/lisp/lisp.factor +++ b/extra/lisp/lisp.factor @@ -3,7 +3,7 @@ USING: kernel peg sequences arrays strings combinators.lib namespaces combinators math locals locals.private accessors vectors syntax lisp.parser assocs parser sequences.lib words quotations -fry lists ; +fry lists inspector ; IN: lisp DEFER: convert-form @@ -16,36 +16,36 @@ DEFER: macro-call ! Functions to convert s-exps to quotations ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : convert-body ( cons -- quot ) - [ ] [ convert-form compose ] reduce-cons ; inline + [ ] [ convert-form compose ] lreduce ; inline : convert-if ( cons -- quot ) - cdr first3 [ convert-form ] tri@ '[ @ , , if ] ; + cdr 3car [ convert-form ] tri@ '[ @ , , if ] ; : convert-begin ( cons -- quot ) - cdr [ convert-form ] [ ] map-as '[ , [ funcall ] each ] ; + cdr [ convert-form ] [ ] lmap-as '[ , [ funcall ] each ] ; : convert-cond ( cons -- quot ) - cdr [ body>> first2 [ convert-form ] bi@ [ '[ @ funcall ] ] dip 2array ] - { } map-as '[ , cond ] ; + cdr [ 2car [ convert-form ] bi@ [ '[ @ funcall ] ] dip 2array ] + { } lmap-as '[ , cond ] ; : convert-general-form ( cons -- quot ) - uncons convert-form swap convert-body swap '[ , @ funcall ] ; + uncons [ convert-body ] [ convert-form ] bi* '[ , @ funcall ] ; ! words for convert-lambda > ] dip at swap or ] - [ dup cons? [ localize-body ] when ] if - ] map-cons ; + dupd [ dup lisp-symbol? [ tuck name>> swap at swap or ] + [ dup cons? [ localize-body ] when nip ] if + ] with lmap ; : localize-lambda ( body vars -- newbody newvars ) make-locals dup push-locals swap - [ swap localize-body cons convert-form swap pop-locals ] dip swap ; + [ swap localize-body seq>cons convert-form swap pop-locals ] dip swap ; -: split-lambda ( cons -- body vars ) - first3 -rot nip [ body>> ] bi@ [ name>> ] map ; inline +: split-lambda ( cons -- body-cons vars-seq ) + 3car -rot nip [ name>> ] lmap ; inline -: rest-lambda ( body vars -- quot ) +: rest-lambda ( body vars -- quot ) "&rest" swap [ index ] [ remove ] 2bi localize-lambda '[ , cut '[ @ , ] , compose ] ; @@ -97,15 +97,20 @@ PRIVATE> SYMBOL: lisp-env ERROR: no-such-var var ; + +SYMBOL: macro-env + +M: no-such-var summary drop "No such variable" ; : init-env ( -- ) - H{ } clone lisp-env set ; + H{ } clone lisp-env set + H{ } clone macro-env set ; : lisp-define ( name quot -- ) swap lisp-env get set-at ; : lisp-get ( name -- word ) - dup lisp-env get at [ ] [ no-such-var throw ] ?if ; + dup lisp-env get at [ ] [ no-such-var ] ?if ; : lookup-var ( lisp-symbol -- quot ) name>> lisp-get ; @@ -114,4 +119,10 @@ ERROR: no-such-var var ; dup lisp-symbol? [ lookup-var ] when call ; inline : define-primitive ( name vocab word -- ) - swap lookup 1quotation '[ , compose call ] lisp-define ; \ No newline at end of file + swap lookup 1quotation '[ , compose call ] lisp-define ; + +: lookup-macro ( lisp-symbol -- macro ) + name>> macro-env get at ; + +: lisp-macro? ( car -- ? ) + dup lisp-symbol? [ name>> macro-env get key? ] [ drop f ] if ; \ No newline at end of file From 8a7dfd76da4dbda2731f63d85efcd514d5106ed7 Mon Sep 17 00:00:00 2001 From: James Cash Date: Wed, 4 Jun 2008 00:02:29 -0400 Subject: [PATCH 34/71] Fixing implementation of leach --- extra/lists/lists.factor | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/extra/lists/lists.factor b/extra/lists/lists.factor index b7e5e6523f..f9b7b89e5b 100644 --- a/extra/lists/lists.factor +++ b/extra/lists/lists.factor @@ -54,11 +54,10 @@ M: cons nil? ( cons -- ? ) 0 (llength) ; : leach ( list quot -- ) - over nil? [ 2drop ] [ [ uncons ] dip tuck call leach ] if ; inline + over nil? [ 2drop ] [ [ uncons swap ] dip tuck [ call ] 2dip leach ] if ; inline : lreduce ( list identity quot -- result ) - pick nil? [ drop nip ] - [ [ uncons ] 2dip swapd [ call ] keep lreduce ] if ; inline + swapd leach ; inline : (lmap) ( acc cons quot -- seq ) over nil? [ 2drop ] From ed18f7d37b24789fc07ba00ac2399344dbb20be9 Mon Sep 17 00:00:00 2001 From: James Cash Date: Wed, 4 Jun 2008 00:56:06 -0400 Subject: [PATCH 35/71] Fixing implementation of nil --- extra/lisp/parser/parser-tests.factor | 9 +++---- extra/lists/lists-docs.factor | 2 +- extra/lists/lists-tests.factor | 16 +++++++----- extra/lists/lists.factor | 36 ++++++++++++++++----------- 4 files changed, 36 insertions(+), 27 deletions(-) diff --git a/extra/lisp/parser/parser-tests.factor b/extra/lisp/parser/parser-tests.factor index 41254db5b3..4aa8154690 100644 --- a/extra/lisp/parser/parser-tests.factor +++ b/extra/lisp/parser/parser-tests.factor @@ -40,8 +40,7 @@ IN: lisp.parser.tests "+" "atom" \ lisp-expr rule parse parse-result-ast ] unit-test -{ T{ cons f f f } -} [ +{ +nil+ } [ "()" lisp-expr parse-result-ast ] unit-test @@ -53,7 +52,7 @@ IN: lisp.parser.tests cons f 1 - T{ cons f 2 T{ cons f "aoeu" T{ cons f f f } } } + T{ cons f 2 T{ cons f "aoeu" +nil+ } } } } } [ "(foo 1 2 \"aoeu\")" lisp-expr parse-result-ast ] unit-test @@ -61,8 +60,8 @@ IN: lisp.parser.tests { T{ cons f 1 T{ cons f - T{ cons f 3 T{ cons f 4 T{ cons f f f } } } - T{ cons f 2 T{ cons f f } } } + T{ cons f 3 T{ cons f 4 +nil+ } } + T{ cons f 2 +nil+ } } } } [ "(1 (3 4) 2)" lisp-expr parse-result-ast diff --git a/extra/lists/lists-docs.factor b/extra/lists/lists-docs.factor index 4fae52f5b4..51b068d979 100644 --- a/extra/lists/lists-docs.factor +++ b/extra/lists/lists-docs.factor @@ -58,7 +58,7 @@ HELP: uncons { $values { "cons" "a cons object" } { "car" "the head of the list" } { "cdr" "the tail of the list" } } { $description "Put the head and tail of the list on the stack." } ; -{ leach lreduce lmap } related-words +{ leach lreduce lmap>array } related-words HELP: leach { $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( obj -- )" } } diff --git a/extra/lists/lists-tests.factor b/extra/lists/lists-tests.factor index 16bc65ebb3..534c20245b 100644 --- a/extra/lists/lists-tests.factor +++ b/extra/lists/lists-tests.factor @@ -9,7 +9,7 @@ IN: lists.tests T{ cons f 2 T{ cons f 3 T{ cons f 4 - T{ cons f f f } } } } } [ 2 + ] lmap + +nil+ } } } } [ 2 + ] lmap>array ] unit-test { 10 } [ @@ -17,7 +17,7 @@ IN: lists.tests T{ cons f 2 T{ cons f 3 T{ cons f 4 - T{ cons f f f } } } } } 0 [ + ] lreduce + +nil+ } } } } 0 [ + ] lreduce ] unit-test { T{ cons f @@ -30,13 +30,17 @@ IN: lists.tests T{ cons f 4 T{ cons f - T{ cons f 5 T{ cons f f f } } - T{ cons f f f } } } } - T{ cons f f f } } } } + T{ cons f 5 +nil+ } + +nil+ } } } + +nil+ } } } } [ { 1 2 { 3 4 { 5 } } } seq>cons ] unit-test { { 1 2 { 3 4 { 5 } } } } [ { 1 2 { 3 4 { 5 } } } seq>cons cons>seq -] unit-test \ No newline at end of file +] unit-test + +! { { 3 4 { 5 6 { 7 } } } } [ +! { 1 2 { 3 4 { 5 } } } seq>cons [ 2 + ] traverse cons>seq +! ] unit-test \ No newline at end of file diff --git a/extra/lists/lists.factor b/extra/lists/lists.factor index f9b7b89e5b..388bfb5bd7 100644 --- a/extra/lists/lists.factor +++ b/extra/lists/lists.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Chris Double & James Cash ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences accessors math arrays vectors classes ; +USING: kernel sequences accessors math arrays vectors classes words ; IN: lists @@ -8,8 +8,8 @@ IN: lists MIXIN: list GENERIC: car ( cons -- car ) GENERIC: cdr ( cons -- cdr ) -GENERIC: nil? ( cons -- ? ) - +GENERIC: nil? ( cons -- ? ) + TUPLE: cons car cdr ; C: cons cons @@ -19,15 +19,15 @@ M: cons car ( cons -- car ) M: cons cdr ( cons -- cdr ) cdr>> ; + +SYMBOL: +nil+ +M: word nil? +nil+ eq? ; +M: object nil? drop f ; -: nil ( -- cons ) - T{ cons f f f } ; +: nil ( -- +nil+ ) +nil+ ; : uncons ( cons -- cdr car ) [ cdr ] [ car ] bi ; - -M: cons nil? ( cons -- ? ) - uncons and not ; : 1list ( obj -- cons ) nil cons ; @@ -59,15 +59,18 @@ M: cons nil? ( cons -- ? ) : lreduce ( list identity quot -- result ) swapd leach ; inline -: (lmap) ( acc cons quot -- seq ) - over nil? [ 2drop ] - [ [ uncons ] dip [ call ] keep swapd [ suffix ] 2dip (lmap) ] if ; inline +! : lmap ( cons quot -- newcons ) -: lmap ( cons quot -- seq ) - { } -rot (lmap) ; inline + +: (lmap>array) ( acc cons quot -- newcons ) + over nil? [ 2drop ] + [ [ uncons ] dip [ call ] keep swapd [ suffix ] 2dip (lmap>array) ] if ; inline + +: lmap>array ( cons quot -- newcons ) + { } -rot (lmap>array) ; inline : lmap-as ( cons quot exemplar -- seq ) - [ lmap ] dip like ; + [ lmap>array ] dip like ; : same? ( obj1 obj2 -- ? ) [ class ] bi@ = ; @@ -76,6 +79,9 @@ M: cons nil? ( cons -- ? ) [ ] keep nil [ tuck same? [ seq>cons ] when f cons swap >>cdr ] with reduce ; : cons>seq ( cons -- array ) - [ dup cons? [ cons>seq ] when ] lmap ; + [ dup cons? [ cons>seq ] when ] lmap>array ; + +: traverse ( list quot -- newlist ) + [ over list? [ traverse ] [ call ] if ] curry ; INSTANCE: cons list \ No newline at end of file From fb247829346f513d047a897fa72d36edc6f0932d Mon Sep 17 00:00:00 2001 From: James Cash Date: Wed, 4 Jun 2008 00:56:30 -0400 Subject: [PATCH 36/71] Fixing indentation in lists/lazy --- extra/lists/lazy/lazy.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/lists/lazy/lazy.factor b/extra/lists/lazy/lazy.factor index 7ab5bbb84e..03e5b0f8cc 100644 --- a/extra/lists/lazy/lazy.factor +++ b/extra/lists/lazy/lazy.factor @@ -82,7 +82,7 @@ TUPLE: lazy-map cons quot ; C: lazy-map : lazy-map ( list quot -- result ) - over nil? [ 2drop nil ] [ ] if ; + over nil? [ 2drop nil ] [ ] if ; M: lazy-map car ( lazy-map -- car ) [ cons>> car ] keep @@ -265,7 +265,7 @@ M: sequence-cons cdr ( sequence-cons -- cdr ) seq>> seq>list ; M: sequence-cons nil? ( sequence-cons -- bool ) - drop f ; + drop f ; : >list ( object -- list ) { From 3ec7d8c20d7fa4987a13e02357a35e98dd06fd4a Mon Sep 17 00:00:00 2001 From: James Cash Date: Wed, 4 Jun 2008 00:58:02 -0400 Subject: [PATCH 37/71] Changing names of lmap to lmap>array --- extra/lisp/lisp.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor index fdcea0eca1..616efcbb1d 100644 --- a/extra/lisp/lisp.factor +++ b/extra/lisp/lisp.factor @@ -36,14 +36,14 @@ DEFER: macro-call : localize-body ( assoc body -- assoc newbody ) dupd [ dup lisp-symbol? [ tuck name>> swap at swap or ] [ dup cons? [ localize-body ] when nip ] if - ] with lmap ; + ] with lmap>array ; : localize-lambda ( body vars -- newbody newvars ) make-locals dup push-locals swap [ swap localize-body seq>cons convert-form swap pop-locals ] dip swap ; : split-lambda ( cons -- body-cons vars-seq ) - 3car -rot nip [ name>> ] lmap ; inline + 3car -rot nip [ name>> ] lmap>array ; inline : rest-lambda ( body vars -- quot ) "&rest" swap [ index ] [ remove ] 2bi From bb050c9f4c6f9581be9b6407737c5a271082b0c1 Mon Sep 17 00:00:00 2001 From: James Cash Date: Wed, 4 Jun 2008 01:40:51 -0400 Subject: [PATCH 38/71] Adding lmap and traverse to extra/lists --- extra/lists/lists-tests.factor | 4 ++++ extra/lists/lists.factor | 8 ++++---- 2 files changed, 8 insertions(+), 4 deletions(-) diff --git a/extra/lists/lists-tests.factor b/extra/lists/lists-tests.factor index 534c20245b..0abb8befeb 100644 --- a/extra/lists/lists-tests.factor +++ b/extra/lists/lists-tests.factor @@ -41,6 +41,10 @@ IN: lists.tests { 1 2 { 3 4 { 5 } } } seq>cons cons>seq ] unit-test +{ T{ cons f 2 T{ cons f 3 T{ cons f 4 T{ cons f 5 +nil+ } } } } } [ + { 1 2 3 4 } seq>cons [ 1+ ] lmap +] unit-test + ! { { 3 4 { 5 6 { 7 } } } } [ ! { 1 2 { 3 4 { 5 } } } seq>cons [ 2 + ] traverse cons>seq ! ] unit-test \ No newline at end of file diff --git a/extra/lists/lists.factor b/extra/lists/lists.factor index 388bfb5bd7..b0fd41fe75 100644 --- a/extra/lists/lists.factor +++ b/extra/lists/lists.factor @@ -59,9 +59,6 @@ M: object nil? drop f ; : lreduce ( list identity quot -- result ) swapd leach ; inline -! : lmap ( cons quot -- newcons ) - - : (lmap>array) ( acc cons quot -- newcons ) over nil? [ 2drop ] [ [ uncons ] dip [ call ] keep swapd [ suffix ] 2dip (lmap>array) ] if ; inline @@ -72,6 +69,9 @@ M: object nil? drop f ; : lmap-as ( cons quot exemplar -- seq ) [ lmap>array ] dip like ; +: lmap ( list quot -- newlist ) + lmap>array nil [ swap cons ] reduce ; + : same? ( obj1 obj2 -- ? ) [ class ] bi@ = ; @@ -82,6 +82,6 @@ M: object nil? drop f ; [ dup cons? [ cons>seq ] when ] lmap>array ; : traverse ( list quot -- newlist ) - [ over list? [ traverse ] [ call ] if ] curry ; + [ over list? [ traverse ] [ call ] if ] curry lmap ; INSTANCE: cons list \ No newline at end of file From 180c7d317878c0d3f7c7b8f2f411e7854d4142c7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 4 Jun 2008 19:14:20 -0500 Subject: [PATCH 39/71] Fix doublec's http.client bugs --- extra/http/client/client.factor | 9 ++++----- extra/openssl/openssl.factor | 8 ++++++-- 2 files changed, 10 insertions(+), 7 deletions(-) diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor index e6c8791e20..7b48bf93af 100755 --- a/extra/http/client/client.factor +++ b/extra/http/client/client.factor @@ -22,7 +22,7 @@ DEFER: http-request SYMBOL: redirects : redirect-url ( request url -- request ) - '[ , >url derive-url ensure-port ] change-url ; + '[ , >url ensure-port derive-url ensure-port ] change-url ; : do-redirect ( response data -- response data ) over code>> 300 399 between? [ @@ -100,12 +100,11 @@ M: download-failed error. : download ( url -- ) dup download-name download-to ; -: ( content-type content url -- request ) +: ( post-data url -- request ) "POST" >>method swap >url ensure-port >>url - swap >>post-data - swap >>post-data-type ; + swap >>post-data ; -: http-post ( content-type content url -- response data ) +: http-post ( post-data url -- response data ) http-request ; diff --git a/extra/openssl/openssl.factor b/extra/openssl/openssl.factor index 03343820db..28fa49dfce 100755 --- a/extra/openssl/openssl.factor +++ b/extra/openssl/openssl.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors byte-arrays kernel debugger sequences namespaces math math.order combinators init alien alien.c-types alien.strings libc -continuations destructors debugger inspector +continuations destructors debugger inspector splitting locals unicode.case openssl.libcrypto openssl.libssl io.backend io.ports io.files io.encodings.8-bit io.sockets.secure @@ -188,8 +188,12 @@ M: ssl-handle dispose* [ 256 X509_NAME_get_text_by_NID ] keep swap -1 = [ drop f ] [ latin1 alien>string ] if ; +: common-names-match? ( expected actual -- ? ) + [ >lower ] bi@ "*." ?head [ tail? ] [ = ] if ; + : check-common-name ( host ssl-handle -- ) - SSL_get_peer_certificate common-name 2dup [ >lower ] bi@ = + SSL_get_peer_certificate common-name + 2dup common-names-match? [ 2drop ] [ common-name-verify-error ] if ; M: openssl check-certificate ( host ssl -- ) From 7cc553c4b6d4f2b0470242f815a6588e0852867b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 4 Jun 2008 19:33:30 -0500 Subject: [PATCH 40/71] Documentation improvements --- core/kernel/kernel-docs.factor | 15 ++++++++++++--- core/syntax/syntax-docs.factor | 2 +- 2 files changed, 13 insertions(+), 4 deletions(-) diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index c39010f228..82f0db1364 100755 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -219,6 +219,16 @@ $nl { $example "t \\ t eq? ." "t" } "Many words which search collections confuse the case of no element being present with an element being found equal to " { $link f } ". If this distinction is imporant, there is usually an alternative word which can be used; for example, compare " { $link at } " with " { $link at* } "." ; +ARTICLE: "conditionals-boolean-equivalence" "Expressing conditionals with boolean logic" +"Certain simple conditional forms can be expressed in a simpler manner using boolean logic." +$nl +"The following two lines are equivalent:" +{ $code "[ drop f ] unless" "swap and" } +"The following two lines are equivalent:" +{ $code "[ ] [ ] ?if" "swap or" } +"The following two lines are equivalent, where " { $snippet "L" } " is a literal:" +{ $code "[ L ] unless*" "L or" } ; + ARTICLE: "conditionals" "Conditionals and logic" "The basic conditionals:" { $subsection if } @@ -238,6 +248,7 @@ ARTICLE: "conditionals" "Conditionals and logic" { $subsection and } { $subsection or } { $subsection xor } +{ $subsection "conditionals-boolean-equivalence" } "See " { $link "combinators" } " for forms which abstract away common patterns involving multiple nested branches." { $see-also "booleans" "bitwise-arithmetic" both? either? } ; @@ -720,9 +731,7 @@ HELP: unless* { $description "Variant of " { $link if* } " with no true quotation." } { $notes "The following two lines are equivalent:" -{ $code "X [ Y ] unless*" "X dup [ ] [ drop Y ] if" } -"The following two lines are equivalent, where " { $snippet "L" } " is a literal:" -{ $code "[ L ] unless*" "L or" } } ; +{ $code "X [ Y ] unless*" "X dup [ ] [ drop Y ] if" } } ; HELP: ?if { $values { "default" object } { "cond" "a generalized boolean" } { "true" "a quotation with stack effect " { $snippet "( cond -- )" } } { "false" "a quotation with stack effect " { $snippet "( default -- )" } } } diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index 0dc834ad6b..18595aaab3 100755 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -346,7 +346,7 @@ HELP: \ { $syntax "\\ word" } { $values { "word" "a word" } } { $description "Reads the next word from the input and appends a wrapper holding the word to the parse tree. When the evaluator encounters a wrapper, it pushes the wrapped word literally on the data stack." } -{ $examples "The following two lines are equivalent:" { $code "0 \\ execute\n0 " } } ; +{ $examples "The following two lines are equivalent:" { $code "0 \\ execute\n0 " } "If " { $snippet "foo" } " is a symbol, the following two lines are equivalent:" { $code "foo" "\\ foo" } } ; HELP: DEFER: { $syntax "DEFER: word" } From ab5843d83174469fd2120c5e83aac77346dc88e4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 4 Jun 2008 19:33:43 -0500 Subject: [PATCH 41/71] Don't need MEMO: there anymore according to doublec --- extra/io/unix/launcher/parser/parser.factor | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) diff --git a/extra/io/unix/launcher/parser/parser.factor b/extra/io/unix/launcher/parser/parser.factor index f3bb82343a..e5e83ab4e9 100755 --- a/extra/io/unix/launcher/parser/parser.factor +++ b/extra/io/unix/launcher/parser/parser.factor @@ -1,7 +1,6 @@ ! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: peg peg.parsers kernel sequences strings words -memoize ; +USING: peg peg.parsers kernel sequences strings words ; IN: io.unix.launcher.parser ! Our command line parser. Supported syntax: @@ -9,20 +8,20 @@ IN: io.unix.launcher.parser ! foo\ bar -- escaping the space ! 'foo bar' -- quotation ! "foo bar" -- quotation -MEMO: 'escaped-char' ( -- parser ) - "\\" token [ drop t ] satisfy 2seq [ second ] action ; +: 'escaped-char' ( -- parser ) + "\\" token any-char 2seq [ second ] action ; -MEMO: 'quoted-char' ( delimiter -- parser' ) +: 'quoted-char' ( delimiter -- parser' ) 'escaped-char' swap [ member? not ] curry satisfy 2choice ; inline -MEMO: 'quoted' ( delimiter -- parser ) +: 'quoted' ( delimiter -- parser ) dup 'quoted-char' repeat0 swap dup surrounded-by ; -MEMO: 'unquoted' ( -- parser ) " '\"" 'quoted-char' repeat1 ; +: 'unquoted' ( -- parser ) " '\"" 'quoted-char' repeat1 ; -MEMO: 'argument' ( -- parser ) +: 'argument' ( -- parser ) "\"" 'quoted' "'" 'quoted' 'unquoted' 3choice From 9861146d8d38fdb34ec8005c830c50c25e42cb37 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 4 Jun 2008 19:54:05 -0500 Subject: [PATCH 42/71] Implement flash scopes, improved validation and login page, improved http-post --- extra/furnace/actions/actions.factor | 92 ++++++++++++------- extra/furnace/asides/asides.factor | 73 +++++++++++++++ extra/furnace/auth/login/login.factor | 48 +++++++--- extra/furnace/auth/login/login.xml | 13 +++ extra/furnace/flash/flash.factor | 38 ++++++++ extra/furnace/flows/flows.factor | 78 ---------------- extra/furnace/furnace-tests.factor | 7 +- extra/furnace/furnace.factor | 57 ++++++------ extra/furnace/sessions/sessions.factor | 13 +-- extra/html/components/components.factor | 22 +++-- extra/html/templates/chloe/chloe-tests.factor | 20 ++++ extra/html/templates/chloe/chloe.factor | 13 ++- extra/html/templates/chloe/test/test10.xml | 3 + extra/html/templates/chloe/test/test11.xml | 14 +++ extra/http/http-tests.factor | 71 ++++++++++++-- extra/http/http.factor | 72 +++++++++------ extra/http/server/cgi/cgi.factor | 8 +- extra/http/server/server-tests.factor | 4 + extra/http/server/server.factor | 2 +- .../factor-website/factor-website.factor | 6 +- extra/webapps/pastebin/paste.xml | 6 +- extra/webapps/pastebin/pastebin-common.xml | 4 +- extra/webapps/pastebin/pastebin.factor | 14 ++- extra/webapps/planet/planet-common.xml | 4 +- extra/webapps/planet/planet.factor | 5 +- extra/webapps/todo/todo.factor | 3 +- extra/webapps/todo/todo.xml | 4 +- extra/webapps/user-admin/user-admin.factor | 16 +--- extra/webapps/user-admin/user-admin.xml | 4 +- extra/webapps/wiki/changes.xml | 2 +- extra/webapps/wiki/wiki-common.xml | 4 +- extra/webapps/wiki/wiki.factor | 13 ++- extra/xml-rpc/example.factor | 4 +- extra/xml-rpc/xml-rpc.factor | 3 +- 34 files changed, 486 insertions(+), 254 deletions(-) create mode 100644 extra/furnace/asides/asides.factor create mode 100644 extra/furnace/flash/flash.factor delete mode 100644 extra/furnace/flows/flows.factor create mode 100644 extra/html/templates/chloe/test/test10.xml create mode 100644 extra/html/templates/chloe/test/test11.xml create mode 100644 extra/http/server/server-tests.factor diff --git a/extra/furnace/actions/actions.factor b/extra/furnace/actions/actions.factor index 5e237b02a8..7340a532e9 100755 --- a/extra/furnace/actions/actions.factor +++ b/extra/furnace/actions/actions.factor @@ -2,13 +2,15 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors sequences kernel assocs combinators validators http hashtables namespaces fry continuations locals -io arrays math boxes +io arrays math boxes splitting urls xml.entities http.server http.server.responses furnace +furnace.flash html.elements html.components +html.components html.templates.chloe html.templates.chloe.syntax ; IN: furnace.actions @@ -39,48 +41,68 @@ TUPLE: action rest-param init display validate submit ; : ( -- action ) action new-action ; +: flashed-variables ( -- seq ) + { validation-messages named-validation-messages } ; + : handle-get ( action -- response ) - blank-values - [ init>> call ] - [ display>> call ] - bi ; + '[ + , + [ init>> call ] + [ drop flashed-variables restore-flash ] + [ display>> call ] + tri + ] with-exit-continuation ; : validation-failed ( -- * ) - request get method>> "POST" = - [ action get display>> call ] [ <400> ] if exit-with ; + request get method>> "POST" = [ f ] [ <400> ] if exit-with ; -: handle-post ( action -- response ) - init-validation - blank-values - [ validate>> call ] - [ submit>> call ] bi ; - -: handle-rest-param ( arg -- ) - dup length 1 > action get rest-param>> not or - [ <404> exit-with ] [ - action get rest-param>> associate rest-param set - ] if ; - -M: action call-responder* ( path action -- response ) - dup action set - '[ - , dup empty? [ drop ] [ handle-rest-param ] if - - init-validation - , - request get - [ request-params rest-param get assoc-union params set ] - [ method>> ] bi - { - { "GET" [ handle-get ] } - { "HEAD" [ handle-get ] } - { "POST" [ handle-post ] } - } case - ] with-exit-continuation ; +: (handle-post) ( action -- response ) + [ validate>> call ] [ submit>> call ] bi ; : param ( name -- value ) params get at ; +: revalidate-url-key "__u" ; + +: check-url ( url -- ? ) + request get url>> + [ [ protocol>> ] [ host>> ] [ port>> ] tri 3array ] bi@ = ; + +: revalidate-url ( -- url/f ) + revalidate-url-key param dup [ >url dup check-url swap and ] when ; + +: handle-post ( action -- response ) + '[ + form-nesting-key params get at " " split + [ , (handle-post) ] + [ swap '[ , , nest-values ] ] reduce + call + ] with-exit-continuation + [ + revalidate-url + [ flashed-variables ] [ <403> ] if* + ] unless* ; + +: handle-rest-param ( path action -- assoc ) + rest-param>> dup [ associate ] [ 2drop f ] if ; + +: init-action ( path action -- ) + blank-values + init-validation + handle-rest-param + request get request-params assoc-union params set ; + +M: action call-responder* ( path action -- response ) + [ init-action ] keep + request get method>> { + { "GET" [ handle-get ] } + { "HEAD" [ handle-get ] } + { "POST" [ handle-post ] } + } case ; + +M: action modify-form + drop request get url>> revalidate-url-key hidden-form-field ; + : check-validation ( -- ) validation-failed? [ validation-failed ] when ; diff --git a/extra/furnace/asides/asides.factor b/extra/furnace/asides/asides.factor new file mode 100644 index 0000000000..f6b4e2c15f --- /dev/null +++ b/extra/furnace/asides/asides.factor @@ -0,0 +1,73 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors namespaces sequences arrays kernel +assocs assocs.lib hashtables math.parser urls combinators +furnace http http.server http.server.filters furnace.sessions +html.elements html.templates.chloe.syntax ; +IN: furnace.asides + +TUPLE: asides < filter-responder ; + +C: asides + +: begin-aside* ( -- id ) + request get + [ url>> ] [ post-data>> ] [ method>> ] tri 3array + asides sget set-at-unique + session-changed ; + +: end-aside-post ( url post-data -- response ) + request [ + clone + swap >>post-data + swap >>url + ] change + request get url>> path>> split-path + asides get responder>> call-responder ; + +ERROR: end-aside-in-get-error ; + +: end-aside* ( url id -- response ) + request get method>> "POST" = [ end-aside-in-get-error ] unless + asides sget at [ + first3 { + { "GET" [ drop ] } + { "HEAD" [ drop ] } + { "POST" [ end-aside-post ] } + } case + ] [ ] ?if ; + +SYMBOL: aside-id + +: aside-id-key "__a" ; + +: begin-aside ( -- ) + begin-aside* aside-id set ; + +: end-aside ( default -- response ) + aside-id [ f ] change end-aside* ; + +M: asides call-responder* + dup asides set + aside-id-key request get request-params at aside-id set + call-next-method ; + +M: asides init-session* + H{ } clone asides sset + call-next-method ; + +M: asides link-attr ( tag -- ) + drop + "aside" optional-attr { + { "none" [ aside-id off ] } + { "begin" [ begin-aside ] } + { "current" [ ] } + { f [ ] } + } case ; + +M: asides modify-query ( query responder -- query' ) + drop + aside-id get [ aside-id-key associate assoc-union ] when* ; + +M: asides modify-form ( responder -- ) + drop aside-id get aside-id-key hidden-form-field ; diff --git a/extra/furnace/auth/login/login.factor b/extra/furnace/auth/login/login.factor index 58ab47e3e1..d0c4e00953 100755 --- a/extra/furnace/auth/login/login.factor +++ b/extra/furnace/auth/login/login.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors quotations assocs kernel splitting combinators sequences namespaces hashtables sets -fry arrays threads qualified random validators +fry arrays threads qualified random validators words io io.sockets io.encodings.utf8 @@ -26,14 +26,29 @@ furnace.auth furnace.auth.providers furnace.auth.providers.db furnace.actions -furnace.flows +furnace.asides +furnace.flash furnace.sessions furnace.boilerplate ; QUALIFIED: smtp IN: furnace.auth.login +: word>string ( word -- string ) + [ word-vocabulary ] [ drop ":" ] [ word-name ] tri 3append ; + +: words>strings ( seq -- seq' ) + [ word>string ] map ; + +: string>word ( string -- word ) + ":" split1 swap lookup ; + +: strings>words ( seq -- seq' ) + [ string>word ] map ; + TUPLE: login < dispatcher users checksum ; +TUPLE: protected < filter-responder description capabilities ; + : users ( -- provider ) login get users>> ; @@ -64,7 +79,7 @@ M: user-saver dispose ! ! ! Login : successful-login ( user -- response ) - username>> set-uid URL" $login" end-flow ; + username>> set-uid URL" $login" end-aside ; : login-failed ( -- * ) "invalid username or password" validation-error @@ -72,6 +87,13 @@ M: user-saver dispose : ( -- action ) + [ + protected fget [ + [ description>> "description" set-value ] + [ capabilities>> words>strings "capabilities" set-value ] bi + ] when* + ] >>init + { login "login" } >>template [ @@ -177,7 +199,7 @@ M: user-saver dispose drop - URL" $login" end-flow + URL" $login" end-aside ] >>submit ; ! ! ! Password recovery @@ -290,23 +312,23 @@ SYMBOL: lost-password-from [ f set-uid - URL" $login" end-flow + URL" $login" end-aside ] >>submit ; ! ! ! Authentication logic - -TUPLE: protected < filter-responder capabilities ; - -C: protected +: ( responder -- protected ) + protected new + swap >>responder ; : show-login-page ( -- response ) - begin-flow - URL" $login/login" ; + begin-aside + URL" $login/login" { protected } ; : check-capabilities ( responder user -- ? ) [ capabilities>> ] bi@ subset? ; M: protected call-responder* ( path responder -- response ) + dup protected set uid dup [ users get-user 2dup check-capabilities [ [ logged-in-user set ] [ save-user-after ] bi @@ -337,7 +359,9 @@ M: login call-responder* ( path responder -- response ) ! ! ! Configuration : allow-edit-profile ( login -- login ) - f + + "edit your profile" >>description + "edit-profile" add-responder ; : allow-registration ( login -- login ) diff --git a/extra/furnace/auth/login/login.xml b/extra/furnace/auth/login/login.xml index a52aed59d7..a7ac92bf44 100644 --- a/extra/furnace/auth/login/login.xml +++ b/extra/furnace/auth/login/login.xml @@ -4,6 +4,19 @@ Login + +

You must log in to .

+ + + +

Your user must have the following capabilities:

+
    + +
    • +     +
+ + diff --git a/extra/furnace/flash/flash.factor b/extra/furnace/flash/flash.factor new file mode 100644 index 0000000000..21fd20ccb4 --- /dev/null +++ b/extra/furnace/flash/flash.factor @@ -0,0 +1,38 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: namespaces assocs assocs.lib kernel sequences urls +http http.server http.server.filters http.server.redirection +furnace furnace.sessions ; +IN: furnace.flash + +: flash-id-key "__f" ; + +TUPLE: flash-scopes < filter-responder ; + +C: flash-scopes + +SYMBOL: flash-scope + +: fget ( key -- value ) flash-scope get at ; + +M: flash-scopes call-responder* + flash-id-key + request get request-params at + flash-scopes sget at flash-scope set + call-next-method ; + +M: flash-scopes init-session* + H{ } clone flash-scopes sset + call-next-method ; + +: make-flash-scope ( seq -- id ) + [ dup get ] H{ } map>assoc flash-scopes sget set-at-unique + session-changed ; + +: ( url seq -- response ) + make-flash-scope + [ clone ] dip flash-id-key set-query-param + ; + +: restore-flash ( seq -- ) + [ flash-scope get key? ] filter [ [ fget ] keep set ] each ; diff --git a/extra/furnace/flows/flows.factor b/extra/furnace/flows/flows.factor deleted file mode 100644 index eb98c1a26b..0000000000 --- a/extra/furnace/flows/flows.factor +++ /dev/null @@ -1,78 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors namespaces sequences arrays kernel -assocs assocs.lib hashtables math.parser urls combinators -furnace http http.server http.server.filters furnace.sessions -html.elements html.templates.chloe.syntax ; -IN: furnace.flows - -TUPLE: flows < filter-responder ; - -C: flows - -: begin-flow* ( -- id ) - request get - [ url>> ] [ post-data>> ] [ method>> ] tri 3array - flows sget set-at-unique - session-changed ; - -: end-flow-post ( url post-data -- response ) - request [ - clone - "POST" >>method - swap >>post-data - swap >>url - ] change - request get url>> path>> split-path - flows get responder>> call-responder ; - -: end-flow* ( url id -- response ) - flows sget at [ - first3 { - { "GET" [ drop ] } - { "HEAD" [ drop ] } - { "POST" [ end-flow-post ] } - } case - ] [ ] ?if ; - -SYMBOL: flow-id - -: flow-id-key "factorflowid" ; - -: begin-flow ( -- ) - begin-flow* flow-id set ; - -: end-flow ( default -- response ) - flow-id get end-flow* ; - -M: flows call-responder* - dup flows set - flow-id-key request get request-params at flow-id set - call-next-method ; - -M: flows init-session* - H{ } clone flows sset - call-next-method ; - -M: flows link-attr ( tag -- ) - drop - "flow" optional-attr { - { "none" [ flow-id off ] } - { "begin" [ begin-flow ] } - { "current" [ ] } - { f [ ] } - } case ; - -M: flows modify-query ( query responder -- query' ) - drop - flow-id get [ flow-id-key associate assoc-union ] when* ; - -M: flows hidden-form-field ( responder -- ) - drop - flow-id get [ - - ] when* ; diff --git a/extra/furnace/furnace-tests.factor b/extra/furnace/furnace-tests.factor index 5cf2dad9ad..f07fe620d8 100644 --- a/extra/furnace/furnace-tests.factor +++ b/extra/furnace/furnace-tests.factor @@ -1,6 +1,7 @@ IN: furnace.tests USING: http.server.dispatchers http.server.responses -http.server furnace tools.test kernel namespaces accessors ; +http.server furnace tools.test kernel namespaces accessors +io.streams.string ; TUPLE: funny-dispatcher < dispatcher ; : funny-dispatcher new-dispatcher ; @@ -28,3 +29,7 @@ M: base-path-check-responder call-responder* V{ } responder-nesting set "a/b/c" split-path main-responder get call-responder body>> ] unit-test + +[ "" ] +[ [ "&&&" "foo" hidden-form-field ] with-string-writer ] +unit-test diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor index 370c4f84a3..f61ec5ff40 100644 --- a/extra/furnace/furnace.factor +++ b/extra/furnace/furnace.factor @@ -6,6 +6,7 @@ vocabs.loader classes fry urls multiline xml xml.data +xml.entities xml.writer xml.utilities html.components @@ -64,15 +65,19 @@ M: object modify-query drop ; { "POST" [ ] } } case ; -GENERIC: hidden-form-field ( responder -- ) +GENERIC: modify-form ( responder -- ) -M: object hidden-form-field drop ; +M: object modify-form drop ; : request-params ( request -- assoc ) dup method>> { { "GET" [ url>> query>> ] } { "HEAD" [ url>> query>> ] } - { "POST" [ post-data>> ] } + { "POST" [ + post-data>> + dup content-type>> "application/x-www-form-urlencoded" = + [ content>> ] [ drop f ] if + ] } } case ; SYMBOL: exit-continuation @@ -128,20 +133,34 @@ CHLOE: a [ drop ] tri ; +: hidden-form-field ( value name -- ) + over [ + string =value + input/> + ] [ 2drop ] if ; + +: form-nesting-key "factorformnesting" ; + +: form-magic ( tag -- ) + [ modify-form ] each-responder + nested-values get " " join f like form-nesting-key hidden-form-field + "for" optional-attr [ hidden render ] when* ; + : form-start-tag ( tag -- ) [ [
- ] [ - [ hidden-form-field ] each-responder - "for" optional-attr [ hidden render ] when* - ] bi + ] + [ form-magic ] bi ] with-scope ; CHLOE: form @@ -167,17 +186,3 @@ CHLOE: button [ [ children>string 1array ] dip "button" tag-named set-tag-children ] [ nip ] } 2cleave process-chloe-tag ; - -: attr>word ( value -- word/f ) - dup ":" split1 swap lookup - [ ] [ "No such word: " swap append throw ] ?if ; - -: attr>var ( value -- word/f ) - attr>word dup symbol? [ - "Must be a symbol: " swap append throw - ] unless ; - -: if-satisfied? ( tag -- ? ) - "code" required-attr attr>word execute ; - -CHLOE: if dup if-satisfied? [ process-tag-children ] [ drop ] if ; diff --git a/extra/furnace/sessions/sessions.factor b/extra/furnace/sessions/sessions.factor index 5ea389c87e..16fefe42fc 100755 --- a/extra/furnace/sessions/sessions.factor +++ b/extra/furnace/sessions/sessions.factor @@ -109,14 +109,14 @@ M: session-saver dispose [ session set ] [ save-session-after ] bi sessions get responder>> call-responder ; -: session-id-key "factorsessid" ; +: session-id-key "__s" ; : cookie-session-id ( request -- id/f ) session-id-key get-cookie dup [ value>> string>number ] when ; : post-session-id ( request -- id/f ) - session-id-key swap post-data>> at string>number ; + session-id-key swap request-params at string>number ; : request-session-id ( -- id/f ) request get dup method>> { @@ -137,13 +137,8 @@ M: session-saver dispose : put-session-cookie ( response -- response' ) session get id>> number>string put-cookie ; -M: sessions hidden-form-field ( responder -- ) - drop - > number>string =value - input/> ; +M: sessions modify-form ( responder -- ) + drop session get id>> session-id-key hidden-form-field ; M: sessions call-responder* ( path responder -- response ) sessions set diff --git a/extra/html/components/components.factor b/extra/html/components/components.factor index c013007a14..90a00ed4ef 100644 --- a/extra/html/components/components.factor +++ b/extra/html/components/components.factor @@ -29,22 +29,30 @@ SYMBOL: values : deposit-slots ( destination names -- ) [ ] dip deposit-values ; -: with-each-index ( seq quot -- ) - '[ +: with-each-index ( name quot -- ) + [ value ] dip '[ [ - values [ clone ] change + blank-values 1+ "index" set-value @ ] with-scope ] each-index ; inline -: with-each-value ( seq quot -- ) +: with-each-value ( name quot -- ) '[ "value" set-value @ ] with-each-index ; inline -: with-each-object ( seq quot -- ) +: with-each-object ( name quot -- ) '[ from-object @ ] with-each-index ; inline -: with-values ( object quot -- ) - '[ blank-values , from-object @ ] with-scope ; inline +SYMBOL: nested-values + +: with-values ( name quot -- ) + '[ + , + [ nested-values [ swap prefix ] change ] + [ value blank-values from-object ] + bi + @ + ] with-scope ; inline : nest-values ( name quot -- ) swap [ diff --git a/extra/html/templates/chloe/chloe-tests.factor b/extra/html/templates/chloe/chloe-tests.factor index d4c02061b2..e50f65141e 100644 --- a/extra/html/templates/chloe/chloe-tests.factor +++ b/extra/html/templates/chloe/chloe-tests.factor @@ -148,3 +148,23 @@ TUPLE: person first-name last-name ; "test9" test-template call-template ] run-template ] unit-test + +[ ] [ H{ { "a" H{ { "b" "c" } } } } values set ] unit-test + +[ "" ] [ + [ + "test10" test-template call-template + ] run-template +] unit-test + +[ ] [ blank-values ] unit-test + +[ ] [ + H{ { "first-name" "RBaxter" } { "last-name" "Unknown" } } "person" set-value +] unit-test + +[ "
RBaxterUnknown
" ] [ + [ + "test11" test-template call-template + ] run-template [ blank? not ] filter +] unit-test diff --git a/extra/html/templates/chloe/chloe.factor b/extra/html/templates/chloe/chloe.factor index 9e0aa3fe1d..cb56bd71ce 100644 --- a/extra/html/templates/chloe/chloe.factor +++ b/extra/html/templates/chloe/chloe.factor @@ -68,7 +68,7 @@ CHLOE: odd "index" value odd? [ process-tag-children ] [ drop ] if ; : (bind-tag) ( tag quot -- ) [ - [ "name" required-attr value ] keep + [ "name" required-attr ] keep '[ , process-tag-children ] ] dip call ; inline @@ -85,6 +85,17 @@ CHLOE: comment drop ; CHLOE: call-next-template drop call-next-template ; +: attr>word ( value -- word/f ) + dup ":" split1 swap lookup + [ ] [ "No such word: " swap append throw ] ?if ; + +: if-satisfied? ( tag -- ? ) + [ "code" optional-attr [ attr>word execute ] [ t ] if* ] + [ "value" optional-attr [ value ] [ t ] if* ] + bi and ; + +CHLOE: if dup if-satisfied? [ process-tag-children ] [ drop ] if ; + CHLOE-SINGLETON: label CHLOE-SINGLETON: link CHLOE-SINGLETON: farkup diff --git a/extra/html/templates/chloe/test/test10.xml b/extra/html/templates/chloe/test/test10.xml new file mode 100644 index 0000000000..33fe2008a5 --- /dev/null +++ b/extra/html/templates/chloe/test/test10.xml @@ -0,0 +1,3 @@ + + + diff --git a/extra/html/templates/chloe/test/test11.xml b/extra/html/templates/chloe/test/test11.xml new file mode 100644 index 0000000000..f74256bd84 --- /dev/null +++ b/extra/html/templates/chloe/test/test11.xml @@ -0,0 +1,14 @@ + + + + + + + + + + + +
+ + diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor index 471d7e276b..c1d5b46aa4 100755 --- a/extra/http/http-tests.factor +++ b/extra/http/http-tests.factor @@ -1,15 +1,16 @@ USING: http tools.test multiline tuple-syntax io.streams.string kernel arrays splitting sequences -assocs io.sockets db db.sqlite continuations urls ; +assocs io.sockets db db.sqlite continuations urls hashtables ; IN: http.tests : lf>crlf "\n" split "\r\n" join ; STRING: read-request-test-1 -GET http://foo/bar HTTP/1.1 +POST http://foo/bar HTTP/1.1 Some-Header: 1 Some-Header: 2 Content-Length: 4 +Content-type: application/octet-stream blah ; @@ -17,10 +18,10 @@ blah [ TUPLE{ request url: TUPLE{ url protocol: "http" port: 80 path: "/bar" } - method: "GET" + method: "POST" version: "1.1" - header: H{ { "some-header" "1; 2" } { "content-length" "4" } } - post-data: "blah" + header: H{ { "some-header" "1; 2" } { "content-length" "4" } { "content-type" "application/octet-stream" } } + post-data: TUPLE{ post-data content: "blah" raw: "blah" content-type: "application/octet-stream" } cookies: V{ } } ] [ @@ -30,8 +31,9 @@ blah ] unit-test STRING: read-request-test-1' -GET /bar HTTP/1.1 +POST /bar HTTP/1.1 content-length: 4 +content-type: application/octet-stream some-header: 1; 2 blah @@ -87,7 +89,7 @@ blah code: 404 message: "not found" header: H{ { "content-type" "text/html; charset=UTF8" } } - cookies: V{ } + cookies: { } content-type: "text/html" content-charset: "UTF8" } @@ -172,7 +174,7 @@ test-db [ [ ] [ [ - f + "" add-responder @@ -219,3 +221,56 @@ test-db [ [ "Hi" ] [ "http://localhost:1237/" http-get ] unit-test [ "Goodbye" ] [ "http://localhost:1237/quit" http-get ] unit-test + +USING: html.components html.elements xml xml.utilities validators +furnace furnace.flash ; + +SYMBOL: a + +[ ] [ + [ + + + [ a get-global "a" set-value ] >>init + [ [ "a" render ] "text/html" ] >>display + [ { { "a" [ v-integer ] } } validate-params ] >>validate + [ "a" value a set-global URL" " ] >>submit + + + >>default + add-quit-action + test-db + main-responder set + + [ 1237 httpd ] "HTTPD test" spawn drop + ] with-scope +] unit-test + +[ ] [ 100 sleep ] unit-test + +3 a set-global + +: test-a string>xml "input" tag-named "value" swap at ; + +[ "3" ] [ + "http://localhost:1237/" http-get* + swap dup cookies>> "cookies" set session-id-key get-cookie + value>> "session-id" set test-a +] unit-test + +[ "4" ] [ + H{ { "a" "4" } { "__u" "http://localhost:1237/" } } "session-id" get session-id-key associate assoc-union + "http://localhost:1237/" "cookies" get >>cookies http-request nip test-a +] unit-test + +[ 4 ] [ a get-global ] unit-test + +! Test flash scope +[ "xyz" ] [ + H{ { "a" "xyz" } { "__u" "http://localhost:1237/" } } "session-id" get session-id-key associate assoc-union + "http://localhost:1237/" "cookies" get >>cookies http-request nip test-a +] unit-test + +[ 4 ] [ a get-global ] unit-test + +[ "Goodbye" ] [ "http://localhost:1237/quit" http-get ] unit-test diff --git a/extra/http/http.factor b/extra/http/http.factor index e8f7189f75..7499796b77 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -10,7 +10,7 @@ io io.server io.sockets.secure unicode.case unicode.categories qualified -urls html.templates ; +urls html.templates xml xml.data xml.writer ; EXCLUDE: fry => , ; @@ -132,7 +132,6 @@ url version header post-data -post-data-type cookies ; : set-header ( request/response value key -- request/response ) @@ -177,19 +176,27 @@ cookies ; : header ( request/response key -- value ) swap header>> at ; -SYMBOL: max-post-request +TUPLE: post-data raw content content-type ; -1024 256 * max-post-request set-global +: ( raw content-type -- post-data ) + post-data new + swap >>content-type + swap >>raw ; -: content-length ( header -- n ) - "content-length" swap at string>number dup [ - dup max-post-request get > [ - "content-length > max-post-request" throw - ] when - ] when ; +: parse-post-data ( post-data -- post-data ) + [ ] [ raw>> ] [ content-type>> ] tri { + { "application/x-www-form-urlencoded" [ query>assoc ] } + { "text/xml" [ string>xml ] } + [ drop ] + } case >>content ; : read-post-data ( request -- request ) - dup header>> content-length [ read >>post-data ] when* ; + dup method>> "POST" = [ + [ ] + [ "content-length" header string>number read ] + [ "content-type" header ] tri + parse-post-data >>post-data + ] when ; : extract-host ( request -- request ) [ ] [ url>> ] [ "host" header parse-host ] tri @@ -197,13 +204,6 @@ SYMBOL: max-post-request ensure-port drop ; -: extract-post-data-type ( request -- request ) - dup "content-type" header >>post-data-type ; - -: parse-post-data ( request -- request ) - dup post-data-type>> "application/x-www-form-urlencoded" = - [ dup post-data>> query>assoc >>post-data ] when ; - : extract-cookies ( request -- request ) dup "cookie" header [ parse-cookies >>cookies ] when* ; @@ -225,8 +225,6 @@ SYMBOL: max-post-request read-post-data detect-protocol extract-host - extract-post-data-type - parse-post-data extract-cookies ; : write-method ( request -- request ) @@ -238,12 +236,6 @@ SYMBOL: max-post-request : write-version ( request -- request ) "HTTP/" write dup request-version write crlf ; -: unparse-post-data ( request -- request ) - dup post-data>> dup sequence? [ drop ] [ - assoc>query >>post-data - "application/x-www-form-urlencoded" >>post-data-type - ] if ; - : url-host ( url -- string ) [ host>> ] [ port>> ] bi dup "http" protocol-port = [ drop ] [ ":" swap number>string 3append ] if ; @@ -251,13 +243,33 @@ SYMBOL: max-post-request : write-request-header ( request -- request ) dup header>> >hashtable over url>> host>> [ over url>> url-host "host" pick set-at ] when - over post-data>> [ length "content-length" pick set-at ] when* - over post-data-type>> [ "content-type" pick set-at ] when* + over post-data>> [ + [ raw>> length "content-length" pick set-at ] + [ content-type>> "content-type" pick set-at ] + bi + ] when* over cookies>> f like [ unparse-cookies "cookie" pick set-at ] when* write-header ; +GENERIC: >post-data ( object -- post-data ) + +M: post-data >post-data ; + +M: string >post-data "application/octet-stream" ; + +M: byte-array >post-data "application/octet-stream" ; + +M: xml >post-data xml>string "text/xml" ; + +M: assoc >post-data assoc>query "application/x-www-form-urlencoded" ; + +M: f >post-data ; + +: unparse-post-data ( request -- request ) + [ >post-data ] change-post-data ; + : write-post-data ( request -- request ) - dup post-data>> [ write ] when* ; + dup method>> "POST" = [ dup post-data>> raw>> write ] when ; : write-request ( request -- ) unparse-post-data @@ -307,7 +319,7 @@ body ; : read-response-header read-header >>header - extract-cookies + dup "set-cookie" header parse-cookies >>cookies dup "content-type" header [ parse-content-type [ >>content-type ] [ >>content-charset ] bi* ] when* ; diff --git a/extra/http/server/cgi/cgi.factor b/extra/http/server/cgi/cgi.factor index cf8a35f141..a6d8948790 100755 --- a/extra/http/server/cgi/cgi.factor +++ b/extra/http/server/cgi/cgi.factor @@ -35,8 +35,10 @@ IN: http.server.cgi request get "accept" header "HTTP_ACCEPT" set post? [ - request get post-data-type>> "CONTENT_TYPE" set - request get post-data>> length number>string "CONTENT_LENGTH" set + request get post-data>> raw>> + [ "CONTENT_TYPE" set ] + [ length number>string "CONTENT_LENGTH" set ] + bi ] when ] H{ } make-assoc ; @@ -51,7 +53,7 @@ IN: http.server.cgi "CGI output follows" >>message swap '[ , output-stream get swap [ - post? [ request get post-data>> write flush ] when + post? [ request get post-data>> raw>> write flush ] when input-stream get swap (stream-copy) ] with-stream ] >>body ; diff --git a/extra/http/server/server-tests.factor b/extra/http/server/server-tests.factor new file mode 100644 index 0000000000..c29912b8c7 --- /dev/null +++ b/extra/http/server/server-tests.factor @@ -0,0 +1,4 @@ +USING: http http.server math sequences continuations tools.test ; +IN: http.server.tests + +[ t ] [ [ \ + first ] [ <500> ] recover response? ] unit-test diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index 756a0de0ff..10d6070f7b 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -40,7 +40,7 @@ main-responder global [ <404> or ] change-at : <500> ( error -- response ) 500 "Internal server error" - development-mode get [ swap '[ , http-error. ] >>body ] [ drop ] if ; + swap development-mode get [ '[ , http-error. ] >>body ] [ drop ] if ; : do-response ( response -- ) dup write-response diff --git a/extra/webapps/factor-website/factor-website.factor b/extra/webapps/factor-website/factor-website.factor index 853af6e845..cd6dde255c 100644 --- a/extra/webapps/factor-website/factor-website.factor +++ b/extra/webapps/factor-website/factor-website.factor @@ -6,7 +6,8 @@ namespaces db db.sqlite smtp http.server http.server.dispatchers furnace.db -furnace.flows +furnace.asides +furnace.flash furnace.sessions furnace.auth.login furnace.auth.providers.db @@ -53,8 +54,7 @@ TUPLE: factor-website < dispatcher ; allow-edit-profile { factor-website "page" } >>template - - + test-db ; : init-factor-website ( -- ) diff --git a/extra/webapps/pastebin/paste.xml b/extra/webapps/pastebin/paste.xml index 9f35d83fd8..453f7b590b 100644 --- a/extra/webapps/pastebin/paste.xml +++ b/extra/webapps/pastebin/paste.xml @@ -28,7 +28,7 @@
- Delete Annotation + Delete Annotation @@ -36,13 +36,13 @@

New Annotation

- + - + diff --git a/extra/webapps/pastebin/pastebin-common.xml b/extra/webapps/pastebin/pastebin-common.xml index 5ef44ad6ce..a27a1290dd 100644 --- a/extra/webapps/pastebin/pastebin-common.xml +++ b/extra/webapps/pastebin/pastebin-common.xml @@ -14,10 +14,10 @@ - | Edit Profile + | Edit Profile - | Logout + | Logout diff --git a/extra/webapps/pastebin/pastebin.factor b/extra/webapps/pastebin/pastebin.factor index 69650b4d73..06cdd5adf0 100644 --- a/extra/webapps/pastebin/pastebin.factor +++ b/extra/webapps/pastebin/pastebin.factor @@ -132,7 +132,7 @@ M: annotation entity-link "id" value "new-annotation" [ - "id" set-value + "parent" set-value mode-names "modes" set-value "factor" "mode" set-value ] nest-values @@ -212,12 +212,12 @@ M: annotation entity-link ] >>display [ - { { "id" [ v-integer ] } } validate-params + { { "parent" [ v-integer ] } } validate-params validate-entity ] >>validate [ - "id" value f + "parent" value f [ deposit-entity-slots ] [ insert-tuple ] [ entity-link ] @@ -246,9 +246,13 @@ can-delete-pastes? define-capability "paste" add-responder "paste.atom" add-responder "new-paste" add-responder - { can-delete-pastes? } "delete-paste" add-responder + + "delete pastes" >>description + { can-delete-pastes? } >>capabilities "delete-paste" add-responder "new-annotation" add-responder - { can-delete-pastes? } "delete-annotation" add-responder + + "delete annotations" >>description + { can-delete-pastes? } >>capabilities "delete-annotation" add-responder { pastebin "pastebin-common" } >>template ; diff --git a/extra/webapps/planet/planet-common.xml b/extra/webapps/planet/planet-common.xml index e92f88c2c2..34ee73da67 100644 --- a/extra/webapps/planet/planet-common.xml +++ b/extra/webapps/planet/planet-common.xml @@ -11,10 +11,10 @@ - | Edit Profile + | Edit Profile - | Logout + | Logout diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor index c5fa5e25d4..3c0e2ad267 100755 --- a/extra/webapps/planet/planet.factor +++ b/extra/webapps/planet/planet.factor @@ -198,7 +198,10 @@ can-administer-planet-factor? define-capability planet-factor new-dispatcher "list" add-main-responder "feed.xml" add-responder - { can-administer-planet-factor? } "admin" add-responder + + "administer Planet Factor" >>description + { can-administer-planet-factor? } >>capabilities + "admin" add-responder { planet-factor "planet-common" } >>template ; diff --git a/extra/webapps/todo/todo.factor b/extra/webapps/todo/todo.factor index 3600e2f874..1cecbc1094 100755 --- a/extra/webapps/todo/todo.factor +++ b/extra/webapps/todo/todo.factor @@ -122,4 +122,5 @@ todo "TODO" "delete" add-responder { todo-list "todo" } >>template - f ; + + "view your todo list" >>description ; diff --git a/extra/webapps/todo/todo.xml b/extra/webapps/todo/todo.xml index 3dd0b9a7d1..e087fbfcfc 100644 --- a/extra/webapps/todo/todo.xml +++ b/extra/webapps/todo/todo.xml @@ -9,10 +9,10 @@ | Add Item - | Edit Profile + | Edit Profile - | Logout + | Logout

diff --git a/extra/webapps/user-admin/user-admin.factor b/extra/webapps/user-admin/user-admin.factor index b8687274f0..78c972fa34 100644 --- a/extra/webapps/user-admin/user-admin.factor +++ b/extra/webapps/user-admin/user-admin.factor @@ -18,18 +18,6 @@ IN: webapps.user-admin TUPLE: user-admin < dispatcher ; -: word>string ( word -- string ) - [ word-vocabulary ] [ drop ":" ] [ word-name ] tri 3append ; - -: words>strings ( seq -- seq' ) - [ word>string ] map ; - -: string>word ( string -- word ) - ":" split1 swap lookup ; - -: strings>words ( seq -- seq' ) - [ string>word ] map ; - : ( -- action ) [ f select-tuples "users" set-value ] >>init @@ -156,7 +144,9 @@ can-administer-users? define-capability "delete" add-responder { user-admin "user-admin" } >>template - { can-administer-users? } ; + + "administer users" >>description + { can-administer-users? } >>capabilities ; : make-admin ( username -- ) diff --git a/extra/webapps/user-admin/user-admin.xml b/extra/webapps/user-admin/user-admin.xml index 93a701a696..9cb9ef0a0a 100644 --- a/extra/webapps/user-admin/user-admin.xml +++ b/extra/webapps/user-admin/user-admin.xml @@ -7,10 +7,10 @@ | Add User - | Edit Profile + | Edit Profile - | Logout + | Logout

diff --git a/extra/webapps/wiki/changes.xml b/extra/webapps/wiki/changes.xml index 95fb0de2fe..5b3e9de2c4 100644 --- a/extra/webapps/wiki/changes.xml +++ b/extra/webapps/wiki/changes.xml @@ -7,7 +7,7 @@
  • - + on by diff --git a/extra/webapps/wiki/wiki-common.xml b/extra/webapps/wiki/wiki-common.xml index 67a5b91c93..c3d203cd2e 100644 --- a/extra/webapps/wiki/wiki-common.xml +++ b/extra/webapps/wiki/wiki-common.xml @@ -13,10 +13,10 @@ - | Edit Profile + | Edit Profile - | Logout + | Logout diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor index 6dcf89e208..dd2e1291f9 100644 --- a/extra/webapps/wiki/wiki.factor +++ b/extra/webapps/wiki/wiki.factor @@ -214,6 +214,10 @@ revision "REVISIONS" { { wiki "user-edits" } >>template ; +SYMBOL: can-delete-wiki-articles? + +can-delete-wiki-articles? define-capability + : ( -- dispatcher ) wiki new-dispatcher @@ -222,7 +226,9 @@ revision "REVISIONS" { "revision" add-responder "revisions" add-responder "diff" add-responder - { } "edit" add-responder + + "edit wiki articles" >>description + "edit" add-responder { wiki "page-common" } >>template >>default @@ -230,6 +236,9 @@ revision "REVISIONS" { "user-edits" add-responder "articles" add-responder "changes" add-responder - { } "delete" add-responder + + "delete wiki articles" >>description + { can-delete-wiki-articles? } >>capabilities + "delete" add-responder { wiki "wiki-common" } >>template ; diff --git a/extra/xml-rpc/example.factor b/extra/xml-rpc/example.factor index 0223dfde69..836a85d52d 100644 --- a/extra/xml-rpc/example.factor +++ b/extra/xml-rpc/example.factor @@ -22,6 +22,6 @@ USING: kernel hashtables xml-rpc xml calendar sequences put-http-response ; : test-rpc-arith - "add" { 1 2 } send-rpc xml>string - "text/xml" swap "http://localhost:8080/responder/rpc/" + "add" { 1 2 } send-rpc + "http://localhost:8080/responder/rpc/" http-post ; diff --git a/extra/xml-rpc/xml-rpc.factor b/extra/xml-rpc/xml-rpc.factor index d41f66739c..4b96d13316 100755 --- a/extra/xml-rpc/xml-rpc.factor +++ b/extra/xml-rpc/xml-rpc.factor @@ -158,8 +158,7 @@ TAG: array xml>item : post-rpc ( rpc url -- rpc ) ! This needs to do something in the event of an error - >r "text/xml" swap send-rpc xml>string r> http-post - 2nip string>xml receive-rpc ; + >r send-rpc r> http-post nip string>xml receive-rpc ; : invoke-method ( params method url -- ) >r swap r> post-rpc ; From 99b23348a8cab1c0c3ab4d70c5204257b374be79 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 5 Jun 2008 00:18:36 -0500 Subject: [PATCH 43/71] Various furnace improvements; add present vocabulary for converting objects to human-readable strings --- extra/furnace/actions/actions-tests.factor | 18 +++++++ extra/furnace/actions/actions.factor | 10 ++-- extra/furnace/furnace-tests.factor | 2 +- extra/furnace/furnace.factor | 14 ++++-- extra/html/components/components-tests.factor | 2 - extra/html/components/components.factor | 48 ++++++++++++------- extra/html/elements/elements.factor | 15 +----- extra/html/templates/chloe/chloe-tests.factor | 14 +++++- extra/html/templates/chloe/chloe.factor | 4 +- extra/html/templates/chloe/test/test12.xml | 3 ++ extra/http/http.factor | 10 ++-- .../server/dispatchers/dispatchers.factor | 9 ++-- .../redirection/redirection-tests.factor | 18 +++---- extra/present/present.factor | 15 ++++++ extra/rss/rss.factor | 6 +-- extra/urls/urls-tests.factor | 6 ++- extra/urls/urls.factor | 34 +++++++++---- 17 files changed, 149 insertions(+), 79 deletions(-) create mode 100644 extra/html/templates/chloe/test/test12.xml create mode 100644 extra/present/present.factor diff --git a/extra/furnace/actions/actions-tests.factor b/extra/furnace/actions/actions-tests.factor index 8aa0f92b97..60a526fb24 100755 --- a/extra/furnace/actions/actions-tests.factor +++ b/extra/furnace/actions/actions-tests.factor @@ -21,3 +21,21 @@ blah init-request { } "action-1" get call-responder ] unit-test + + + "a" >>rest + [ "a" param string>number sq ] >>display +"action-2" set + +STRING: action-request-test-2 +GET http://foo/bar/123 HTTP/1.1 + +blah +; + +[ 25 ] [ + action-request-test-2 lf>crlf + [ read-request ] with-string-reader + init-request + { "5" } "action-2" get call-responder +] unit-test diff --git a/extra/furnace/actions/actions.factor b/extra/furnace/actions/actions.factor index 7340a532e9..1cef8e24e5 100755 --- a/extra/furnace/actions/actions.factor +++ b/extra/furnace/actions/actions.factor @@ -17,7 +17,7 @@ IN: furnace.actions SYMBOL: params -SYMBOL: rest-param +SYMBOL: rest : render-validation-messages ( -- ) validation-messages get @@ -29,7 +29,7 @@ SYMBOL: rest-param CHLOE: validation-messages drop render-validation-messages ; -TUPLE: action rest-param init display validate submit ; +TUPLE: action rest init display validate submit ; : new-action ( class -- action ) new @@ -83,13 +83,13 @@ TUPLE: action rest-param init display validate submit ; [ flashed-variables ] [ <403> ] if* ] unless* ; -: handle-rest-param ( path action -- assoc ) - rest-param>> dup [ associate ] [ 2drop f ] if ; +: handle-rest ( path action -- assoc ) + rest>> dup [ [ "/" join ] dip associate ] [ 2drop f ] if ; : init-action ( path action -- ) blank-values init-validation - handle-rest-param + handle-rest request get request-params assoc-union params set ; M: action call-responder* ( path action -- response ) diff --git a/extra/furnace/furnace-tests.factor b/extra/furnace/furnace-tests.factor index f07fe620d8..223b20455d 100644 --- a/extra/furnace/furnace-tests.factor +++ b/extra/furnace/furnace-tests.factor @@ -30,6 +30,6 @@ M: base-path-check-responder call-responder* "a/b/c" split-path main-responder get call-responder body>> ] unit-test -[ "" ] +[ "" ] [ [ "&&&" "foo" hidden-form-field ] with-string-writer ] unit-test diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor index f61ec5ff40..4859d8b0f6 100644 --- a/extra/furnace/furnace.factor +++ b/extra/furnace/furnace.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays kernel combinators assocs continuations namespaces sequences splitting words -vocabs.loader classes -fry urls multiline +vocabs.loader classes strings +fry urls multiline present xml xml.data xml.entities @@ -52,12 +52,16 @@ GENERIC: modify-query ( query responder -- query' ) M: object modify-query drop ; -: adjust-url ( url -- url' ) +GENERIC: adjust-url ( url -- url' ) + +M: url adjust-url clone [ [ modify-query ] each-responder ] change-query [ resolve-base-path ] change-path relative-to-request ; +M: string adjust-url ; + : ( url -- response ) adjust-url request get method>> { { "GET" [ ] } @@ -138,11 +142,11 @@ CHLOE: a string =value + present =value input/> ] [ 2drop ] if ; -: form-nesting-key "factorformnesting" ; +: form-nesting-key "__n" ; : form-magic ( tag -- ) [ modify-form ] each-responder diff --git a/extra/html/components/components-tests.factor b/extra/html/components/components-tests.factor index 1f77768115..2ae120b527 100644 --- a/extra/html/components/components-tests.factor +++ b/extra/html/components/components-tests.factor @@ -17,8 +17,6 @@ TUPLE: color red green blue ; [ ] [ "jimmy" "red" set-value ] unit-test -[ "123.5" ] [ 123.5 object>string ] unit-test - [ "jimmy" ] [ [ "red" label render diff --git a/extra/html/components/components.factor b/extra/html/components/components.factor index 90a00ed4ef..72dabad84e 100644 --- a/extra/html/components/components.factor +++ b/extra/html/components/components.factor @@ -5,7 +5,7 @@ classes.tuple words arrays sequences sequences.lib splitting mirrors hashtables combinators continuations math strings fry locals calendar calendar.format xml.entities validators html.elements html.streams xmode.code2html farkup inspector -lcs.diff2html urls ; +lcs.diff2html urls present ; IN: html.components SYMBOL: values @@ -29,19 +29,25 @@ SYMBOL: values : deposit-slots ( destination names -- ) [ ] dip deposit-values ; -: with-each-index ( name quot -- ) +: with-each-value ( name quot -- ) [ value ] dip '[ [ - blank-values - 1+ "index" set-value @ + values [ clone ] change + 1+ "index" set-value + "value" set-value + @ ] with-scope ] each-index ; inline -: with-each-value ( name quot -- ) - '[ "value" set-value @ ] with-each-index ; inline - : with-each-object ( name quot -- ) - '[ from-object @ ] with-each-index ; inline + [ value ] dip '[ + [ + blank-values + 1+ "index" set-value + from-object + @ + ] with-scope + ] each-index ; inline SYMBOL: nested-values @@ -75,13 +81,13 @@ GENERIC: render* ( value name render -- ) string =value input/> ; + ; PRIVATE> SINGLETON: label -M: label render* 2drop object>string escape-string write ; +M: label render* 2drop present escape-string write ; SINGLETON: hidden @@ -90,9 +96,9 @@ M: hidden render* drop "hidden" render-input ; : render-field ( value name size type -- ) string =size ] when* + [ present =size ] when* =name - object>string =value + present =value input/> ; TUPLE: field size ; @@ -119,11 +125,11 @@ TUPLE: textarea rows cols ; M: textarea render* ; ! Choice @@ -134,7 +140,7 @@ TUPLE: choice size multiple choices ; : render-option ( text selected? -- ) ; : render-options ( options selected -- ) @@ -143,7 +149,7 @@ TUPLE: choice size multiple choices ; M: choice render* " ] [ +[ "
    " ] [ [ "test10" test-template call-template ] run-template @@ -168,3 +168,15 @@ TUPLE: person first-name last-name ; "test11" test-template call-template ] run-template [ blank? not ] filter ] unit-test + +[ ] [ + blank-values + { "a" "b" } "choices" set-value + "true" "b" set-value +] unit-test + +[ "ab" ] [ + [ + "test12" test-template call-template + ] run-template +] unit-test diff --git a/extra/html/templates/chloe/chloe.factor b/extra/html/templates/chloe/chloe.factor index cb56bd71ce..08d6b873fc 100644 --- a/extra/html/templates/chloe/chloe.factor +++ b/extra/html/templates/chloe/chloe.factor @@ -3,7 +3,7 @@ USING: accessors kernel sequences combinators kernel namespaces classes.tuple assocs splitting words arrays memoize io io.files io.encodings.utf8 io.streams.string -unicode.case tuple-syntax mirrors fry math urls +unicode.case tuple-syntax mirrors fry math urls present multiline xml xml.data xml.writer xml.utilities html.elements html.components @@ -127,7 +127,7 @@ CHLOE-TUPLE: code : expand-attrs ( tag -- tag ) dup [ tag? ] is? [ clone [ - [ "@" ?head [ value object>string ] when ] assoc-map + [ "@" ?head [ value present ] when ] assoc-map ] change-attrs ] when ; diff --git a/extra/html/templates/chloe/test/test12.xml b/extra/html/templates/chloe/test/test12.xml new file mode 100644 index 0000000000..b26778c96e --- /dev/null +++ b/extra/html/templates/chloe/test/test12.xml @@ -0,0 +1,3 @@ + + + diff --git a/extra/http/http.factor b/extra/http/http.factor index 7499796b77..abbf79f860 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -4,7 +4,7 @@ USING: accessors kernel combinators math namespaces assocs sequences splitting sorting sets debugger strings vectors hashtables quotations arrays byte-arrays -math.parser calendar calendar.format +math.parser calendar calendar.format present io io.server io.sockets.secure @@ -54,11 +54,9 @@ IN: http : header-value>string ( value -- string ) { - { [ dup number? ] [ number>string ] } { [ dup timestamp? ] [ timestamp>http-string ] } - { [ dup url? ] [ url>string ] } - { [ dup string? ] [ ] } - { [ dup sequence? ] [ [ header-value>string ] map "; " join ] } + { [ dup array? ] [ [ header-value>string ] map "; " join ] } + [ present ] } cond ; : check-header-string ( str -- str ) @@ -231,7 +229,7 @@ TUPLE: post-data raw content content-type ; dup method>> write bl ; : write-request-url ( request -- request ) - dup url>> relative-url url>string write bl ; + dup url>> relative-url present write bl ; : write-version ( request -- request ) "HTTP/" write dup request-version write crlf ; diff --git a/extra/http/server/dispatchers/dispatchers.factor b/extra/http/server/dispatchers/dispatchers.factor index 36eb447fc3..2da2695992 100644 --- a/extra/http/server/dispatchers/dispatchers.factor +++ b/extra/http/server/dispatchers/dispatchers.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel namespaces sequences assocs accessors -http http.server http.server.responses ; +USING: kernel namespaces sequences assocs accessors splitting +unicode.case http http.server http.server.responses ; IN: http.server.dispatchers TUPLE: dispatcher default responders ; @@ -31,8 +31,11 @@ TUPLE: vhost-dispatcher default responders ; : ( -- dispatcher ) vhost-dispatcher new-dispatcher ; +: canonical-host ( host -- host' ) + >lower "www." ?head drop "." ?tail drop ; + : find-vhost ( dispatcher -- responder ) - request get url>> host>> over responders>> at* + request get url>> host>> canonical-host over responders>> at* [ nip ] [ drop default>> ] if ; M: vhost-dispatcher call-responder* ( path dispatcher -- response ) diff --git a/extra/http/server/redirection/redirection-tests.factor b/extra/http/server/redirection/redirection-tests.factor index 0b88231855..04af89ec98 100644 --- a/extra/http/server/redirection/redirection-tests.factor +++ b/extra/http/server/redirection/redirection-tests.factor @@ -1,6 +1,6 @@ IN: http.server.redirection.tests USING: http http.server.redirection urls accessors -namespaces tools.test ; +namespaces tools.test present ; \ relative-to-request must-infer @@ -15,34 +15,34 @@ namespaces tools.test ; request set [ "http://www.apple.com:80/xxx/bar" ] [ - relative-to-request url>string + relative-to-request present ] unit-test [ "http://www.apple.com:80/xxx/baz" ] [ - "baz" >>path relative-to-request url>string + "baz" >>path relative-to-request present ] unit-test [ "http://www.apple.com:80/xxx/baz?c=d" ] [ - "baz" >>path { { "c" "d" } } >>query relative-to-request url>string + "baz" >>path { { "c" "d" } } >>query relative-to-request present ] unit-test [ "http://www.apple.com:80/xxx/bar?c=d" ] [ - { { "c" "d" } } >>query relative-to-request url>string + { { "c" "d" } } >>query relative-to-request present ] unit-test [ "http://www.apple.com:80/flip" ] [ - "/flip" >>path relative-to-request url>string + "/flip" >>path relative-to-request present ] unit-test [ "http://www.apple.com:80/flip?c=d" ] [ - "/flip" >>path { { "c" "d" } } >>query relative-to-request url>string + "/flip" >>path { { "c" "d" } } >>query relative-to-request present ] unit-test [ "http://www.jedit.org:80/" ] [ - "http://www.jedit.org" >url relative-to-request url>string + "http://www.jedit.org" >url relative-to-request present ] unit-test [ "http://www.jedit.org:80/?a=b" ] [ - "http://www.jedit.org" >url { { "a" "b" } } >>query relative-to-request url>string + "http://www.jedit.org" >url { { "a" "b" } } >>query relative-to-request present ] unit-test ] with-scope diff --git a/extra/present/present.factor b/extra/present/present.factor new file mode 100644 index 0000000000..1fae84184a --- /dev/null +++ b/extra/present/present.factor @@ -0,0 +1,15 @@ +USING: math math.parser calendar calendar.format strings words +kernel ; +IN: present + +GENERIC: present ( object -- string ) + +M: real present number>string ; + +M: timestamp present timestamp>string ; + +M: string present ; + +M: word present word-name ; + +M: f present drop "" ; diff --git a/extra/rss/rss.factor b/extra/rss/rss.factor index 5183af5145..1dd66ff5d4 100644 --- a/extra/rss/rss.factor +++ b/extra/rss/rss.factor @@ -4,7 +4,7 @@ USING: xml.utilities kernel assocs xml.generator math.order strings sequences xml.data xml.writer io.streams.string combinators xml xml.entities io.files io http.client namespaces xml.generator hashtables - calendar.format accessors continuations urls ; + calendar.format accessors continuations urls present ; IN: rss : any-tag-named ( tag names -- tag-inside ) @@ -104,7 +104,7 @@ C: entry : entry, ( entry -- ) "entry" [ dup title>> "title" { { "type" "html" } } simple-tag*, - "link" over link>> dup url? [ url>string ] when "href" associate contained*, + "link" over link>> dup url? [ present ] when "href" associate contained*, dup pub-date>> timestamp>rfc3339 "published" simple-tag, description>> [ "content" { { "type" "html" } } simple-tag*, ] when* ] tag, ; @@ -112,6 +112,6 @@ C: entry : feed>xml ( feed -- xml ) "feed" { { "xmlns" "http://www.w3.org/2005/Atom" } } [ dup title>> "title" simple-tag, - "link" over link>> dup url? [ url>string ] when "href" associate contained*, + "link" over link>> dup url? [ present ] when "href" associate contained*, entries>> [ entry, ] each ] make-xml* ; diff --git a/extra/urls/urls-tests.factor b/extra/urls/urls-tests.factor index 080352449b..a718989476 100644 --- a/extra/urls/urls-tests.factor +++ b/extra/urls/urls-tests.factor @@ -1,5 +1,7 @@ IN: urls.tests -USING: urls tools.test tuple-syntax arrays kernel assocs ; +USING: urls urls.private tools.test +tuple-syntax arrays kernel assocs +present ; [ "hello%20world" ] [ "hello world" url-encode ] unit-test [ "hello world" ] [ "hello%20world" url-decode ] unit-test @@ -110,7 +112,7 @@ urls [ ] assoc-each urls [ - swap [ 1array ] [ [ url>string ] curry ] bi* unit-test + swap [ 1array ] [ [ present ] curry ] bi* unit-test ] assoc-each [ "b" ] [ "a" "b" url-append-path ] unit-test diff --git a/extra/urls/urls.factor b/extra/urls/urls.factor index 5c89205d5b..bb4d17e1f5 100644 --- a/extra/urls/urls.factor +++ b/extra/urls/urls.factor @@ -4,7 +4,7 @@ USING: kernel unicode.categories combinators sequences splitting fry namespaces assocs arrays strings io.sockets io.sockets.secure io.encodings.string io.encodings.utf8 math math.parser accessors mirrors parser -prettyprint.backend hashtables ; +prettyprint.backend hashtables present ; IN: urls : url-quotable? ( ch -- ? ) @@ -14,19 +14,25 @@ IN: urls { [ dup letter? ] [ t ] } { [ dup LETTER? ] [ t ] } { [ dup digit? ] [ t ] } - { [ dup "/_-.:" member? ] [ t ] } + { [ dup "/_-." member? ] [ t ] } [ f ] } cond nip ; foldable +hex 2 CHAR: 0 pad-left % ] each ; +PRIVATE> + : url-encode ( str -- str ) [ [ dup url-quotable? [ , ] [ push-utf8 ] if ] each ] "" make ; += [ 2drop @@ -51,9 +57,13 @@ IN: urls ] if url-decode-iter ] if ; +PRIVATE> + : url-decode ( str -- str ) [ 0 swap url-decode-iter ] "" make utf8 decode ; + + : query>assoc ( query -- assoc ) dup [ "&" split H{ } clone [ @@ -77,11 +89,7 @@ IN: urls : assoc>query ( hash -- str ) [ - { - { [ dup number? ] [ number>string 1array ] } - { [ dup string? ] [ 1array ] } - { [ dup sequence? ] [ ] } - } cond + dup array? [ [ present ] map ] [ present 1array ] if ] assoc-map [ [ @@ -108,6 +116,8 @@ TUPLE: url protocol username password host port path query anchor ; ] when ] bi* ; +>protocol ] [ "//" ?head [ "Invalid URL" throw ] unless @@ -121,6 +131,8 @@ TUPLE: url protocol username password host port path query anchor ; ] [ "/" prepend ] bi* ] bi* ; +PRIVATE> + GENERIC: >url ( obj -- url ) M: url >url ; @@ -135,6 +147,8 @@ M: string >url ] [ url-decode >>anchor ] bi* ; +> dup [ % password>> [ ":" % % ] when* "@" % @@ -150,7 +164,7 @@ M: string >url [ path>> "/" head? [ "/" % ] unless ] } cleave ; -: url>string ( url -- string ) +M: url present [ { [ dup protocol>> dup [ unparse-host-part ] [ 2drop ] if ] @@ -169,6 +183,8 @@ M: string >url [ [ "/" last-split1 drop "/" ] dip 3append ] } cond ; +PRIVATE> + : derive-url ( base url -- url' ) [ clone dup ] dip 2dup [ path>> ] bi@ url-append-path @@ -199,4 +215,4 @@ M: string >url ! Literal syntax : URL" lexer get skip-blank parse-string >url parsed ; parsing -M: url pprint* dup url>string "URL\" " "\"" pprint-string ; +M: url pprint* dup present "URL\" " "\"" pprint-string ; From 19044920dc71550cecac50c5ea01eb38c8645b95 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 5 Jun 2008 01:12:22 -0500 Subject: [PATCH 44/71] Clean up RSS library --- extra/rss/rss-tests.factor | 10 ++-- extra/rss/rss.factor | 97 ++++++++++++++++++++++---------------- 2 files changed, 62 insertions(+), 45 deletions(-) diff --git a/extra/rss/rss-tests.factor b/extra/rss/rss-tests.factor index 0e6bb0b9c1..4ecb7fc965 100755 --- a/extra/rss/rss-tests.factor +++ b/extra/rss/rss-tests.factor @@ -1,5 +1,5 @@ USING: rss io kernel io.files tools.test io.encodings.utf8 -calendar ; +calendar urls ; IN: rss.tests : load-news-file ( filename -- feed ) @@ -11,13 +11,13 @@ IN: rss.tests feed f "Meerkat" - "http://meerkat.oreillynet.com" + URL" http://meerkat.oreillynet.com" { T{ entry f "XML: A Disruptive Technology" - "http://c.moreover.com/click/here.pl?r123" + URL" http://c.moreover.com/click/here.pl?r123" "\n XML is placing increasingly heavy loads on the existing technical\n infrastructure of the Internet.\n " f } @@ -27,13 +27,13 @@ IN: rss.tests feed f "dive into mark" - "http://example.org/" + URL" http://example.org/" { T{ entry f "Atom draft-07 snapshot" - "http://example.org/2005/04/02/atom" + URL" http://example.org/2005/04/02/atom" "\n
    \n

    [Update: The Atom draft is finished.]

    \n
    \n " T{ timestamp f 2003 12 13 8 29 29 T{ duration f 0 0 0 -4 0 0 } } diff --git a/extra/rss/rss.factor b/extra/rss/rss.factor index 1dd66ff5d4..4aa92abc67 100644 --- a/extra/rss/rss.factor +++ b/extra/rss/rss.factor @@ -10,75 +10,89 @@ IN: rss : any-tag-named ( tag names -- tag-inside ) f -rot [ tag-named nip dup ] with find 2drop ; -TUPLE: feed title link entries ; +TUPLE: feed title url entries ; -C: feed +: ( -- feed ) feed new ; -TUPLE: entry title link description pub-date ; +TUPLE: entry title url description pub-date ; -C: entry +: set-entries ( feed entries -- feed ) + [ dup url>> ] dip + [ [ derive-url ] change-url ] with map + >>entries ; + +: ( -- entry ) entry new ; : try-parsing-timestamp ( string -- timestamp ) [ rfc822>timestamp ] [ drop rfc3339>timestamp ] recover ; : rss1.0-entry ( tag -- entry ) - { - [ "title" tag-named children>string ] - [ "link" tag-named children>string ] - [ "description" tag-named children>string ] + entry new + swap { + [ "title" tag-named children>string >>title ] + [ "link" tag-named children>string >url >>url ] + [ "description" tag-named children>string >>description ] [ f "date" "http://purl.org/dc/elements/1.1/" tag-named dup [ children>string try-parsing-timestamp ] when + >>pub-date ] - } cleave ; + } cleave ; : rss1.0 ( xml -- feed ) - [ + feed new + swap [ "channel" tag-named - [ "title" tag-named children>string ] - [ "link" tag-named children>string ] bi - ] [ "item" tags-named [ rss1.0-entry ] map ] bi - ; + [ "title" tag-named children>string >>title ] + [ "link" tag-named children>string >url >>url ] bi + ] [ "item" tags-named [ rss1.0-entry ] map set-entries ] bi ; : rss2.0-entry ( tag -- entry ) - { - [ "title" tag-named children>string ] - [ { "link" "guid" } any-tag-named children>string ] - [ "description" tag-named children>string ] + entry new + swap { + [ "title" tag-named children>string >>title ] + [ { "link" "guid" } any-tag-named children>string >url >>url ] + [ "description" tag-named children>string >>description ] [ { "date" "pubDate" } any-tag-named - children>string try-parsing-timestamp + children>string try-parsing-timestamp >>pub-date ] - } cleave ; + } cleave ; : rss2.0 ( xml -- feed ) + feed new + swap "channel" tag-named - [ "title" tag-named children>string ] - [ "link" tag-named children>string ] - [ "item" tags-named [ rss2.0-entry ] map ] - tri ; + [ "title" tag-named children>string >>title ] + [ "link" tag-named children>string >>link ] + [ "item" tags-named [ rss2.0-entry ] map set-entries ] + tri ; : atom1.0-entry ( tag -- entry ) - { - [ "title" tag-named children>string ] - [ "link" tag-named "href" swap at ] + entry new + swap { + [ "title" tag-named children>string >>title ] + [ "link" tag-named "href" swap at >url >>url ] [ { "content" "summary" } any-tag-named dup tag-children [ string? not ] contains? [ tag-children [ write-chunk ] with-string-writer ] - [ children>string ] if + [ children>string ] if >>description ] [ { "published" "updated" "issued" "modified" } any-tag-named children>string try-parsing-timestamp + >>pub-date ] - } cleave ; + } cleave ; : atom1.0 ( xml -- feed ) - [ "title" tag-named children>string ] - [ "link" tag-named "href" swap at ] - [ "entry" tags-named [ atom1.0-entry ] map ] - tri ; + feed new + swap + [ "title" tag-named children>string >>title ] + [ "link" tag-named "href" swap at >url >>url ] + [ "entry" tags-named [ atom1.0-entry ] map set-entries ] + tri ; : xml>feed ( xml -- feed ) dup name-tag { @@ -103,15 +117,18 @@ C: entry : entry, ( entry -- ) "entry" [ - dup title>> "title" { { "type" "html" } } simple-tag*, - "link" over link>> dup url? [ present ] when "href" associate contained*, - dup pub-date>> timestamp>rfc3339 "published" simple-tag, - description>> [ "content" { { "type" "html" } } simple-tag*, ] when* + { + [ title>> "title" { { "type" "html" } } simple-tag*, ] + [ url>> present "href" associate "link" swap contained*, ] + [ pub-date>> timestamp>rfc3339 "published" simple-tag, ] + [ description>> [ "content" { { "type" "html" } } simple-tag*, ] when* ] + } cleave ] tag, ; : feed>xml ( feed -- xml ) "feed" { { "xmlns" "http://www.w3.org/2005/Atom" } } [ - dup title>> "title" simple-tag, - "link" over link>> dup url? [ present ] when "href" associate contained*, - entries>> [ entry, ] each + [ title>> "title" simple-tag, ] + [ url>> present "href" associate "link" swap contained*, ] + [ entries>> [ entry, ] each ] + tri ] make-xml* ; From 608276fe9aa6d249344aa46cee24376fe6bf2ad0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 5 Jun 2008 01:48:31 -0500 Subject: [PATCH 45/71] Improve furnace RSS support --- extra/furnace/furnace.factor | 4 +-- extra/furnace/rss/rss.factor | 48 ++++++++++++++++++++++++++++++++---- extra/rss/rss-tests.factor | 3 +++ extra/rss/rss.factor | 12 ++++----- 4 files changed, 54 insertions(+), 13 deletions(-) diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor index 4859d8b0f6..862ed80e11 100644 --- a/extra/furnace/furnace.factor +++ b/extra/furnace/furnace.factor @@ -8,7 +8,6 @@ xml xml.data xml.entities xml.writer -xml.utilities html.components html.elements html.templates @@ -20,6 +19,7 @@ http.server.redirection http.server.responses qualified ; QUALIFIED-WITH: assocs a +EXCLUDE: xml.utilities => children>string ; IN: furnace : nested-responders ( -- seq ) @@ -97,7 +97,7 @@ SYMBOL: exit-continuation [ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ; CHLOE: atom - [ "title" required-attr ] + [ children>string ] [ "href" required-attr ] [ "query" optional-attr parse-query-attr ] tri diff --git a/extra/furnace/rss/rss.factor b/extra/furnace/rss/rss.factor index a94ef4fe51..c2163eda66 100644 --- a/extra/furnace/rss/rss.factor +++ b/extra/furnace/rss/rss.factor @@ -1,14 +1,52 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel fry -rss http.server.responses furnace.actions ; +USING: accessors kernel sequences fry sequences.lib +combinators rss http.server.responses http.server.redirection +furnace furnace.actions ; IN: furnace.rss +GENERIC: feed-entry-title ( object -- string ) + +GENERIC: feed-entry-date ( object -- timestamp ) + +GENERIC: feed-entry-url ( object -- url ) + +GENERIC: feed-entry-description ( object -- description ) + +M: object feed-entry-description drop f ; + +GENERIC: >entry ( object -- entry ) + +M: entry >entry ; + +M: object >entry + + swap { + [ feed-entry-title >>title ] + [ feed-entry-date >>date ] + [ feed-entry-url >>url ] + [ feed-entry-description >>description ] + } cleave ; + +: process-entries ( seq -- seq' ) + 20 short head-slice [ + >entry clone + [ adjust-url relative-to-request ] change-url + ] map ; + : ( body -- response ) feed>xml "application/atom+xml" ; -TUPLE: feed-action < action feed ; +TUPLE: feed-action < action title url entries ; -: ( -- feed ) +: ( -- action ) feed-action new-action - dup '[ , feed>> call ] >>display ; + dup '[ + feed new + , + [ title>> call >>title ] + [ url>> call adjust-url relative-to-request >>url ] + [ entries>> call process-entries >>entries ] + tri + + ] >>display ; diff --git a/extra/rss/rss-tests.factor b/extra/rss/rss-tests.factor index 4ecb7fc965..81a0bf9e1a 100755 --- a/extra/rss/rss-tests.factor +++ b/extra/rss/rss-tests.factor @@ -2,6 +2,9 @@ USING: rss io kernel io.files tools.test io.encodings.utf8 calendar urls ; IN: rss.tests +\ download-feed must-infer +\ feed>xml must-infer + : load-news-file ( filename -- feed ) #! Load an news syndication file and process it, returning #! it as an feed tuple. diff --git a/extra/rss/rss.factor b/extra/rss/rss.factor index 4aa92abc67..7696a7c220 100644 --- a/extra/rss/rss.factor +++ b/extra/rss/rss.factor @@ -14,7 +14,7 @@ TUPLE: feed title url entries ; : ( -- feed ) feed new ; -TUPLE: entry title url description pub-date ; +TUPLE: entry title url description date ; : set-entries ( feed entries -- feed ) [ dup url>> ] dip @@ -35,7 +35,7 @@ TUPLE: entry title url description pub-date ; [ f "date" "http://purl.org/dc/elements/1.1/" tag-named dup [ children>string try-parsing-timestamp ] when - >>pub-date + >>date ] } cleave ; @@ -55,7 +55,7 @@ TUPLE: entry title url description pub-date ; [ "description" tag-named children>string >>description ] [ { "date" "pubDate" } any-tag-named - children>string try-parsing-timestamp >>pub-date + children>string try-parsing-timestamp >>date ] } cleave ; @@ -64,7 +64,7 @@ TUPLE: entry title url description pub-date ; swap "channel" tag-named [ "title" tag-named children>string >>title ] - [ "link" tag-named children>string >>link ] + [ "link" tag-named children>string >url >>url ] [ "item" tags-named [ rss2.0-entry ] map set-entries ] tri ; @@ -82,7 +82,7 @@ TUPLE: entry title url description pub-date ; [ { "published" "updated" "issued" "modified" } any-tag-named children>string try-parsing-timestamp - >>pub-date + >>date ] } cleave ; @@ -120,7 +120,7 @@ TUPLE: entry title url description pub-date ; { [ title>> "title" { { "type" "html" } } simple-tag*, ] [ url>> present "href" associate "link" swap contained*, ] - [ pub-date>> timestamp>rfc3339 "published" simple-tag, ] + [ date>> timestamp>rfc3339 "published" simple-tag, ] [ description>> [ "content" { { "type" "html" } } simple-tag*, ] when* ] } cleave ] tag, ; From 465f460834faa9b3bc667487340a607947053657 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 5 Jun 2008 01:50:26 -0500 Subject: [PATCH 46/71] Port old Wee-URL web app to new framework --- extra/webapps/wee-url/shorten.xml | 10 ++++ extra/webapps/wee-url/show.xml | 11 +++++ extra/webapps/wee-url/wee-url.factor | 74 ++++++++++++++++++++++++++++ extra/webapps/wee-url/wee-url.xml | 13 +++++ 4 files changed, 108 insertions(+) create mode 100644 extra/webapps/wee-url/shorten.xml create mode 100644 extra/webapps/wee-url/show.xml create mode 100644 extra/webapps/wee-url/wee-url.factor create mode 100644 extra/webapps/wee-url/wee-url.xml diff --git a/extra/webapps/wee-url/shorten.xml b/extra/webapps/wee-url/shorten.xml new file mode 100644 index 0000000000..8df7774fba --- /dev/null +++ b/extra/webapps/wee-url/shorten.xml @@ -0,0 +1,10 @@ + + + + + +

    Shorten URL:

    + +     + +     diff --git a/extra/webapps/wee-url/show.xml b/extra/webapps/wee-url/show.xml new file mode 100644 index 0000000000..ba44629bb1 --- /dev/null +++ b/extra/webapps/wee-url/show.xml @@ -0,0 +1,11 @@ + + + + +

    The URL:

    +
    +

    has been shortened to:

    +
    +

    enjoy!

    + +     diff --git a/extra/webapps/wee-url/wee-url.factor b/extra/webapps/wee-url/wee-url.factor new file mode 100644 index 0000000000..afdacf9add --- /dev/null +++ b/extra/webapps/wee-url/wee-url.factor @@ -0,0 +1,74 @@ +! Copyright (C) 2007 Doug Coleman. +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: math.ranges sequences random accessors combinators.lib +kernel namespaces fry db.types db.tuples urls validators +html.components http http.server.dispatchers furnace +furnace.actions furnace.boilerplate ; +IN: webapps.wee-url + +TUPLE: wee-url < dispatcher ; + +TUPLE: short-url short url ; + +short-url "SHORT_URLS" { + { "short" "SHORT" TEXT +user-assigned-id+ } + { "url" "URL" TEXT +not-null+ } +} define-persistent + +: init-short-url-table ( -- ) + short-url ensure-table ; + +: letter-bank ( -- seq ) + CHAR: a CHAR: z [a,b] + CHAR: A CHAR: Z [a,b] + CHAR: 1 CHAR: 0 [a,b] + 3append ; foldable + +: random-url ( -- string ) + 1 6 [a,b] random [ drop letter-bank random ] "" map-as ; + +: insert-short-url ( short-url -- short-url ) + '[ , dup random-url >>short insert-tuple ] 10 retry ; + +: shorten ( url -- short ) + short-url new swap >>url dup select-tuple + [ ] [ insert-short-url ] ?if short>> ; + +: short>url ( short -- url ) + "$wee-url/go/" prepend >url adjust-url ; + +: expand-url ( string -- url ) + short-url new swap >>short select-tuple url>> ; + +: ( -- action ) + + { wee-url "shorten" } >>template + [ { { "url" [ v-url ] } } validate-params ] >>validate + [ + "$wee-url/show/" "url" value shorten append >url + ] >>submit ; + +: ( -- action ) + + "short" >>rest + [ + { { "short" [ v-one-word ] } } validate-params + "short" value expand-url "url" set-value + "short" value short>url "short" set-value + ] >>init + { wee-url "show" } >>template ; + +: ( -- action ) + + "short" >>rest + [ { { "short" [ v-one-word ] } } validate-params ] >>init + [ "short" value expand-url ] >>display ; + +: ( -- wee-url ) + wee-url new-dispatcher + "" add-responder + "show" add-responder + "go" add-responder + + { wee-url "wee-url" } >>template ; diff --git a/extra/webapps/wee-url/wee-url.xml b/extra/webapps/wee-url/wee-url.xml new file mode 100644 index 0000000000..98d1095ed6 --- /dev/null +++ b/extra/webapps/wee-url/wee-url.xml @@ -0,0 +1,13 @@ + + + + + WeeURL! + +
    Shorten URL
    + +

    + + + +     From 89feb17f321c04ff9d8dd72ff4fed944b102dd08 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 5 Jun 2008 01:50:47 -0500 Subject: [PATCH 47/71] Add wee-url to website dispatcher --- extra/webapps/factor-website/factor-website.factor | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/extra/webapps/factor-website/factor-website.factor b/extra/webapps/factor-website/factor-website.factor index cd6dde255c..44899cba31 100644 --- a/extra/webapps/factor-website/factor-website.factor +++ b/extra/webapps/factor-website/factor-website.factor @@ -16,6 +16,7 @@ webapps.pastebin webapps.planet webapps.todo webapps.wiki +webapps.wee-url webapps.user-admin ; IN: webapps.factor-website @@ -36,6 +37,8 @@ IN: webapps.factor-website init-articles-table init-revisions-table + + init-short-url-table ] with-db ; TUPLE: factor-website < dispatcher ; @@ -46,6 +49,7 @@ TUPLE: factor-website < dispatcher ; "pastebin" add-responder "planet" add-responder "wiki" add-responder + "wee-url" add-responder "user-admin" add-responder users-in-db >>users From 1074bdb3303acebaeb715ce8d8312c99247c46d7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 5 Jun 2008 01:50:59 -0500 Subject: [PATCH 48/71] Update wiki, pastebin, planet for new furnace.rss code --- extra/webapps/pastebin/paste.xml | 4 +- extra/webapps/pastebin/pastebin-common.xml | 2 +- extra/webapps/pastebin/pastebin.factor | 87 +++++-------- extra/webapps/planet/admin.xml | 4 +- extra/webapps/planet/mini-planet.xml | 2 +- extra/webapps/planet/planet.factor | 28 ++-- extra/webapps/planet/planet.xml | 4 +- extra/webapps/user-admin/user-admin.factor | 2 +- extra/webapps/wiki/page-common.xml | 4 + extra/webapps/wiki/user-edits.xml | 4 + extra/webapps/wiki/wiki-common.xml | 4 + extra/webapps/wiki/wiki.factor | 145 +++++++++++++-------- 12 files changed, 153 insertions(+), 137 deletions(-) diff --git a/extra/webapps/pastebin/paste.xml b/extra/webapps/pastebin/paste.xml index 453f7b590b..ea69c7bf7d 100644 --- a/extra/webapps/pastebin/paste.xml +++ b/extra/webapps/pastebin/paste.xml @@ -2,7 +2,9 @@ - + + Paste: + Paste: diff --git a/extra/webapps/pastebin/pastebin-common.xml b/extra/webapps/pastebin/pastebin-common.xml index a27a1290dd..47f7666b22 100644 --- a/extra/webapps/pastebin/pastebin-common.xml +++ b/extra/webapps/pastebin/pastebin-common.xml @@ -2,7 +2,7 @@ - + Pastebin diff --git a/extra/webapps/pastebin/pastebin.factor b/extra/webapps/pastebin/pastebin.factor index 06cdd5adf0..882e7cf438 100644 --- a/extra/webapps/pastebin/pastebin.factor +++ b/extra/webapps/pastebin/pastebin.factor @@ -35,6 +35,14 @@ entity f { "contents" "CONTENTS" TEXT +not-null+ } } define-persistent +GENERIC: entity-url ( entity -- url ) + +M: entity feed-entry-title summary>> ; + +M: entity feed-entry-date date>> ; + +M: entity feed-entry-url entity-url ; + TUPLE: paste < entity annotations ; \ paste "PASTES" { } define-persistent @@ -58,39 +66,31 @@ annotation "ANNOTATIONS" swap >>id swap >>parent ; -: fetch-annotations ( paste -- paste ) - dup annotations>> [ - dup id>> f select-tuples >>annotations - ] unless ; - : paste ( id -- paste ) - select-tuple fetch-annotations ; + [ select-tuple ] + [ f select-tuples ] + bi >>annotations ; ! ! ! ! LINKS, ETC ! ! ! -: pastebin-link ( -- url ) +: pastebin-url ( -- url ) URL" $pastebin/list" ; -GENERIC: entity-link ( entity -- url ) +: paste-url ( id -- url ) + "$pastebin/paste" >url swap "id" set-query-param ; -: paste-link ( id -- url ) - - "$pastebin/paste" >>path - swap "id" set-query-param ; +M: paste entity-url + id>> paste-url ; -M: paste entity-link - id>> paste-link ; - -: annotation-link ( parent id -- url ) - - "$pastebin/paste" >>path +: annotation-url ( parent id -- url ) + "$pastebin/paste" >url swap number>string >>anchor swap "id" set-query-param ; -M: annotation entity-link - [ parent>> ] [ id>> ] bi annotation-link ; +M: annotation entity-url + [ parent>> ] [ id>> ] bi annotation-url ; ! ! ! ! PASTE LIST @@ -101,24 +101,11 @@ M: annotation entity-link [ pastes "pastes" set-value ] >>init { pastebin "pastebin" } >>template ; -: pastebin-feed-entries ( seq -- entries ) - 20 short head [ - entry new - swap - [ summary>> >>title ] - [ date>> >>pub-date ] - [ entity-link adjust-url relative-to-request >>link ] - tri - ] map ; - -: pastebin-feed ( -- feed ) - feed new - "Factor Pastebin" >>title - pastebin-link >>link - pastes pastebin-feed-entries >>entries ; - : ( -- action ) - [ pastebin-feed ] >>feed ; + + [ pastebin-url ] >>url + [ "Factor Pastebin" ] >>title + [ pastes ] >>entries ; ! ! ! ! PASTES @@ -140,21 +127,12 @@ M: annotation entity-link { pastebin "paste" } >>template ; -: paste-feed-entries ( paste -- entries ) - fetch-annotations annotations>> pastebin-feed-entries ; - -: paste-feed ( paste -- feed ) - feed new - swap - [ "Paste " swap id>> number>string append >>title ] - [ entity-link adjust-url relative-to-request >>link ] - [ paste-feed-entries >>entries ] - tri ; - : ( -- action ) [ validate-integer-id ] >>init - [ "id" value paste paste-feed ] >>feed ; + [ "id" value paste-url ] >>url + [ "Paste " "id" value number>string append ] >>title + [ "id" value f select-tuples ] >>entries ; : validate-entity ( -- ) { @@ -186,7 +164,7 @@ M: annotation entity-link f [ deposit-entity-slots ] [ insert-tuple ] - [ id>> paste-link ] + [ id>> paste-url ] tri ] >>submit ; @@ -206,11 +184,6 @@ M: annotation entity-link : ( -- action ) - [ - { { "id" [ v-integer ] } } validate-params - "id" value paste-link - ] >>display - [ { { "parent" [ v-integer ] } } validate-params validate-entity @@ -220,7 +193,7 @@ M: annotation entity-link "parent" value f [ deposit-entity-slots ] [ insert-tuple ] - [ entity-link ] + [ entity-url ] tri ] >>submit ; @@ -231,7 +204,7 @@ M: annotation entity-link [ f "id" value select-tuple [ delete-tuples ] - [ parent>> paste-link ] + [ parent>> paste-url ] bi ] >>submit ; diff --git a/extra/webapps/planet/admin.xml b/extra/webapps/planet/admin.xml index 26a3e6f206..192592489e 100644 --- a/extra/webapps/planet/admin.xml +++ b/extra/webapps/planet/admin.xml @@ -14,9 +14,9 @@
-

+

Add Blog | Update -

+
diff --git a/extra/webapps/planet/mini-planet.xml b/extra/webapps/planet/mini-planet.xml index 8de7216b0e..661c2dc0f7 100644 --- a/extra/webapps/planet/mini-planet.xml +++ b/extra/webapps/planet/mini-planet.xml @@ -5,7 +5,7 @@

-
+
Read More...

diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor index 3c0e2ad267..0237e14faa 100755 --- a/extra/webapps/planet/planet.factor +++ b/extra/webapps/planet/planet.factor @@ -34,16 +34,15 @@ blog "BLOGS" { "feed-url" "FEEDURL" { VARCHAR 256 } +not-null+ } } define-persistent -! TUPLE: posting < entry id ; -TUPLE: posting id title link description pub-date ; +TUPLE: posting < entry id ; posting "POSTINGS" { { "id" "ID" INTEGER +db-assigned-id+ } { "title" "TITLE" { VARCHAR 256 } +not-null+ } - { "link" "LINK" { VARCHAR 256 } +not-null+ } + { "url" "LINK" { VARCHAR 256 } +not-null+ } { "description" "DESCRIPTION" TEXT +not-null+ } - { "pub-date" "DATE" TIMESTAMP +not-null+ } + { "date" "DATE" TIMESTAMP +not-null+ } } define-persistent : init-blog-table blog ensure-table ; @@ -60,7 +59,7 @@ posting "POSTINGS" : postings ( -- seq ) posting new select-tuples - [ [ pub-date>> ] compare invert-comparison ] sort ; + [ [ date>> ] compare invert-comparison ] sort ; : ( -- action ) @@ -76,21 +75,18 @@ posting "POSTINGS" { planet-factor "planet" } >>template ; -: planet-feed ( -- feed ) - feed new - "Planet Factor" >>title - "http://planet.factorcode.org" >>link - postings >>entries ; - : ( -- action ) - [ planet-feed ] >>feed ; + + [ "Planet Factor" ] >>title + [ URL" $planet-factor" ] >>url + [ postings ] >>entries ; :: ( entry name -- entry' ) posting new name ": " entry title>> 3append >>title - entry link>> >>link + entry url>> >>url entry description>> >>description - entry pub-date>> >>pub-date ; + entry date>> >>date ; : fetch-feed ( url -- feed ) download-feed entries>> ; @@ -102,7 +98,7 @@ posting "POSTINGS" [ '[ , ] map ] 2map concat ; : sort-entries ( entries -- entries' ) - [ [ pub-date>> ] compare invert-comparison ] sort ; + [ [ date>> ] compare invert-comparison ] sort ; : update-cached-postings ( -- ) blogroll fetch-blogroll sort-entries 8 short head [ @@ -197,7 +193,7 @@ can-administer-planet-factor? define-capability : ( -- responder ) planet-factor new-dispatcher "list" add-main-responder - "feed.xml" add-responder + "feed.xml" add-responder "administer Planet Factor" >>description { can-administer-planet-factor? } >>capabilities diff --git a/extra/webapps/planet/planet.xml b/extra/webapps/planet/planet.xml index 213c314d7a..96343bc5fa 100644 --- a/extra/webapps/planet/planet.xml +++ b/extra/webapps/planet/planet.xml @@ -11,7 +11,7 @@

- +

@@ -19,7 +19,7 @@

- +

diff --git a/extra/webapps/user-admin/user-admin.factor b/extra/webapps/user-admin/user-admin.factor index 78c972fa34..19153e1354 100644 --- a/extra/webapps/user-admin/user-admin.factor +++ b/extra/webapps/user-admin/user-admin.factor @@ -83,7 +83,7 @@ TUPLE: user-admin < dispatcher ; [ from-object ] [ capabilities>> [ "true" swap word>string set-value ] each ] bi - capabilities get words>strings "capabilities" set-value + init-capabilities ] >>init { user-admin "edit-user" } >>template diff --git a/extra/webapps/wiki/page-common.xml b/extra/webapps/wiki/page-common.xml index 1d4b507320..675cb8cd65 100644 --- a/extra/webapps/wiki/page-common.xml +++ b/extra/webapps/wiki/page-common.xml @@ -2,6 +2,10 @@ + + Revisions of + +
diff --git a/extra/webapps/wiki/user-edits.xml b/extra/webapps/wiki/user-edits.xml index 61809802d9..6f22982f12 100644 --- a/extra/webapps/wiki/user-edits.xml +++ b/extra/webapps/wiki/user-edits.xml @@ -2,6 +2,10 @@ + + Edits by + + Edits by
    diff --git a/extra/webapps/wiki/wiki-common.xml b/extra/webapps/wiki/wiki-common.xml index c3d203cd2e..4c6d1a5b5c 100644 --- a/extra/webapps/wiki/wiki-common.xml +++ b/extra/webapps/wiki/wiki-common.xml @@ -2,6 +2,10 @@ + + Recent Changes + +
    diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor index dd2e1291f9..c7c43715a7 100644 --- a/extra/webapps/wiki/wiki.factor +++ b/extra/webapps/wiki/wiki.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel hashtables calendar namespaces splitting sequences sorting math.order -html.components +html.components rss http.server http.server.dispatchers furnace @@ -10,10 +10,26 @@ furnace.actions furnace.auth furnace.auth.login furnace.boilerplate +furnace.rss validators db.types db.tuples lcs farkup urls ; IN: webapps.wiki +: title-url ( title action -- url ) + "$wiki/" prepend >url swap "title" set-query-param ; + +: view-url ( title -- url ) "view" title-url ; + +: edit-url ( title -- url ) "edit" title-url ; + +: revisions-url ( title -- url ) "revisions" title-url ; + +: revision-url ( id -- url ) + "$wiki/revision" >url swap "id" set-query-param ; + +: user-edits-url ( author -- url ) + "$wiki/user-edits" >url swap "author" set-query-param ; + TUPLE: wiki < dispatcher ; TUPLE: article title revision ; @@ -39,6 +55,16 @@ revision "REVISIONS" { { "content" "CONTENT" TEXT +not-null+ } } define-persistent +M: revision feed-entry-title + [ title>> ] [ drop " by " ] [ author>> ] tri 3append ; + +M: revision feed-entry-date date>> ; + +M: revision feed-entry-url id>> revision-url ; + +: reverse-chronological-order ( seq -- sorted ) + [ [ date>> ] compare invert-comparison ] sort ; + : ( id -- revision ) revision new swap >>id ; @@ -47,18 +73,16 @@ revision "REVISIONS" { : validate-title ( -- ) { { "title" [ v-one-line ] } } validate-params ; +: validate-author ( -- ) + { { "author" [ v-username ] } } validate-params ; + : ( -- action ) - [ - - "$wiki/view" >>path - "Front Page" "title" set-query-param - - ] >>display ; + [ "Front Page" view-url ] >>display ; : ( -- action ) - "title" >>rest-param + "title" >>rest [ validate-title @@ -70,17 +94,14 @@ revision "REVISIONS" { revision>> select-tuple from-object { wiki "view" } ] [ - - "$wiki/edit" >>path - swap "title" set-query-param - + edit-url ] ?if ] >>display ; : ( -- action ) [ - { { "id" [ v-integer ] } } validate-params + validate-integer-id "id" value select-tuple from-object ] >>init @@ -117,53 +138,53 @@ revision "REVISIONS" { now >>date logged-in-user get username>> >>author "content" value >>content - [ add-revision ] - [ - - "$wiki/view" >>path - swap title>> "title" set-query-param - - ] bi + [ add-revision ] [ title>> view-url ] bi ] >>submit ; +: list-revisions ( -- seq ) + f "title" value >>title select-tuples + reverse-chronological-order ; + : ( -- action ) [ validate-title - f "title" value >>title select-tuples - [ [ date>> ] compare invert-comparison ] sort - "revisions" set-value + list-revisions "revisions" set-value ] >>init - { wiki "revisions" } >>template ; +: ( -- action ) + + [ validate-title ] >>init + [ "Revisions of " "title" value append ] >>title + [ "title" value revisions-url ] >>url + [ list-revisions ] >>entries ; + : ( -- action ) - [ - { { "id" [ v-integer ] } } validate-params - ] >>validate - + [ validate-integer-id ] >>validate + [ "id" value select-tuple clone f >>id - [ add-revision ] - [ - - "$wiki/view" >>path - swap title>> "title" set-query-param - - ] bi + [ add-revision ] [ title>> view-url ] bi ] >>submit ; +: list-changes ( -- seq ) + "id" value select-tuples + reverse-chronological-order ; + : ( -- action ) - [ - f select-tuples - [ [ date>> ] compare invert-comparison ] sort - "changes" set-value - ] >>init + [ list-changes "changes" set-value ] >>init { wiki "changes" } >>template ; +: ( -- action ) + + [ URL" $wiki/changes" ] >>url + [ "All changes" ] >>title + [ list-changes ] >>entries ; + : ( -- action ) [ validate-title ] >>validate @@ -204,38 +225,50 @@ revision "REVISIONS" { { wiki "articles" } >>template ; +: list-user-edits ( -- seq ) + f "author" value >>author select-tuples + reverse-chronological-order ; + : ( -- action ) [ - { { "author" [ v-username ] } } validate-params - f "author" value >>author - select-tuples "user-edits" set-value + validate-author + list-user-edits "user-edits" set-value ] >>init - { wiki "user-edits" } >>template ; +: ( -- action ) + + [ validate-author ] >>init + [ "Edits by " "author" value append ] >>title + [ "author" value user-edits-url ] >>url + [ list-user-edits ] >>entries ; + SYMBOL: can-delete-wiki-articles? can-delete-wiki-articles? define-capability +: ( responder -- responder' ) + + { wiki "page-common" } >>template ; + : ( -- dispatcher ) wiki new-dispatcher - - "" add-responder - "view" add-responder - "revision" add-responder - "revisions" add-responder - "diff" add-responder - - "edit wiki articles" >>description - "edit" add-responder - - { wiki "page-common" } >>template - >>default + "" add-responder + "view" add-responder + "revision" add-responder + "revisions" add-responder + "revisions.atom" add-responder + "diff" add-responder + + "edit wiki articles" >>description + "edit" add-responder "rollback" add-responder "user-edits" add-responder "articles" add-responder "changes" add-responder + "user-edits.atom" add-responder + "changes.atom" add-responder "delete wiki articles" >>description { can-delete-wiki-articles? } >>capabilities From aec1363400456c14117f26230c44d61bcf3ee308 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 5 Jun 2008 01:56:06 -0500 Subject: [PATCH 49/71] Rename rss to syndication --- .../{rss/rss.factor => syndication/syndication.factor} | 5 +++-- extra/rss/authors.txt | 1 - extra/syndication/authors.txt | 3 +++ extra/{rss => syndication}/readme.txt | 0 extra/{rss => syndication}/summary.txt | 0 .../syndication-tests.factor} | 8 ++++---- extra/{rss/rss.factor => syndication/syndication.factor} | 3 ++- extra/syndication/tags.txt | 1 + extra/{rss => syndication/test}/atom.xml | 0 extra/{rss => syndication/test}/rss1.xml | 0 extra/webapps/pastebin/pastebin.factor | 4 ++-- extra/webapps/planet/planet.factor | 4 ++-- extra/webapps/wiki/wiki.factor | 4 ++-- 13 files changed, 19 insertions(+), 14 deletions(-) rename extra/furnace/{rss/rss.factor => syndication/syndication.factor} (93%) delete mode 100755 extra/rss/authors.txt create mode 100755 extra/syndication/authors.txt rename extra/{rss => syndication}/readme.txt (100%) rename extra/{rss => syndication}/summary.txt (100%) rename extra/{rss/rss-tests.factor => syndication/syndication-tests.factor} (81%) rename extra/{rss/rss.factor => syndication/syndication.factor} (98%) create mode 100644 extra/syndication/tags.txt rename extra/{rss => syndication/test}/atom.xml (100%) rename extra/{rss => syndication/test}/rss1.xml (100%) diff --git a/extra/furnace/rss/rss.factor b/extra/furnace/syndication/syndication.factor similarity index 93% rename from extra/furnace/rss/rss.factor rename to extra/furnace/syndication/syndication.factor index c2163eda66..7f60bcc746 100644 --- a/extra/furnace/rss/rss.factor +++ b/extra/furnace/syndication/syndication.factor @@ -1,9 +1,10 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel sequences fry sequences.lib -combinators rss http.server.responses http.server.redirection +combinators syndication +http.server.responses http.server.redirection furnace furnace.actions ; -IN: furnace.rss +IN: furnace.syndication GENERIC: feed-entry-title ( object -- string ) diff --git a/extra/rss/authors.txt b/extra/rss/authors.txt deleted file mode 100755 index f990dd0ed2..0000000000 --- a/extra/rss/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Daniel Ehrenberg diff --git a/extra/syndication/authors.txt b/extra/syndication/authors.txt new file mode 100755 index 0000000000..89b32cecee --- /dev/null +++ b/extra/syndication/authors.txt @@ -0,0 +1,3 @@ +Daniel Ehrenberg +Chris Double +Slava Pestov diff --git a/extra/rss/readme.txt b/extra/syndication/readme.txt similarity index 100% rename from extra/rss/readme.txt rename to extra/syndication/readme.txt diff --git a/extra/rss/summary.txt b/extra/syndication/summary.txt similarity index 100% rename from extra/rss/summary.txt rename to extra/syndication/summary.txt diff --git a/extra/rss/rss-tests.factor b/extra/syndication/syndication-tests.factor similarity index 81% rename from extra/rss/rss-tests.factor rename to extra/syndication/syndication-tests.factor index 81a0bf9e1a..73541e7908 100755 --- a/extra/rss/rss-tests.factor +++ b/extra/syndication/syndication-tests.factor @@ -1,6 +1,6 @@ -USING: rss io kernel io.files tools.test io.encodings.utf8 +USING: syndication io kernel io.files tools.test io.encodings.utf8 calendar urls ; -IN: rss.tests +IN: syndication.tests \ download-feed must-infer \ feed>xml must-infer @@ -25,7 +25,7 @@ IN: rss.tests f } } -} ] [ "resource:extra/rss/rss1.xml" load-news-file ] unit-test +} ] [ "resource:extra/syndication/test/rss1.xml" load-news-file ] unit-test [ T{ feed f @@ -42,4 +42,4 @@ IN: rss.tests T{ timestamp f 2003 12 13 8 29 29 T{ duration f 0 0 0 -4 0 0 } } } } -} ] [ "resource:extra/rss/atom.xml" load-news-file ] unit-test +} ] [ "resource:extra/syndication/test/atom.xml" load-news-file ] unit-test diff --git a/extra/rss/rss.factor b/extra/syndication/syndication.factor similarity index 98% rename from extra/rss/rss.factor rename to extra/syndication/syndication.factor index 7696a7c220..12beaf4cd7 100644 --- a/extra/rss/rss.factor +++ b/extra/syndication/syndication.factor @@ -1,11 +1,12 @@ ! Copyright (C) 2006 Chris Double, Daniel Ehrenberg. +! Portions copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: xml.utilities kernel assocs xml.generator math.order strings sequences xml.data xml.writer io.streams.string combinators xml xml.entities io.files io http.client namespaces xml.generator hashtables calendar.format accessors continuations urls present ; -IN: rss +IN: syndication : any-tag-named ( tag names -- tag-inside ) f -rot [ tag-named nip dup ] with find 2drop ; diff --git a/extra/syndication/tags.txt b/extra/syndication/tags.txt new file mode 100644 index 0000000000..c0772185a0 --- /dev/null +++ b/extra/syndication/tags.txt @@ -0,0 +1 @@ +web diff --git a/extra/rss/atom.xml b/extra/syndication/test/atom.xml similarity index 100% rename from extra/rss/atom.xml rename to extra/syndication/test/atom.xml diff --git a/extra/rss/rss1.xml b/extra/syndication/test/rss1.xml similarity index 100% rename from extra/rss/rss1.xml rename to extra/syndication/test/rss1.xml diff --git a/extra/webapps/pastebin/pastebin.factor b/extra/webapps/pastebin/pastebin.factor index 882e7cf438..9e477d6156 100644 --- a/extra/webapps/pastebin/pastebin.factor +++ b/extra/webapps/pastebin/pastebin.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: namespaces assocs sorting sequences kernel accessors hashtables sequences.lib db.types db.tuples db combinators -calendar calendar.format math.parser rss urls xml.writer +calendar calendar.format math.parser syndication urls xml.writer xmode.catalog validators html.components html.templates.chloe @@ -14,7 +14,7 @@ furnace.actions furnace.auth furnace.auth.login furnace.boilerplate -furnace.rss ; +furnace.syndication ; IN: webapps.pastebin TUPLE: pastebin < dispatcher ; diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor index 0237e14faa..5af96cd4f7 100755 --- a/extra/webapps/planet/planet.factor +++ b/extra/webapps/planet/planet.factor @@ -4,7 +4,7 @@ USING: kernel accessors sequences sorting math math.order calendar alarms logging concurrency.combinators namespaces sequences.lib db.types db.tuples db fry locals hashtables html.components -rss urls xml.writer +syndication urls xml.writer validators http.server http.server.dispatchers @@ -13,7 +13,7 @@ furnace.actions furnace.boilerplate furnace.auth.login furnace.auth -furnace.rss ; +furnace.syndication ; IN: webapps.planet TUPLE: planet-factor < dispatcher ; diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor index c7c43715a7..dbba4dac08 100644 --- a/extra/webapps/wiki/wiki.factor +++ b/extra/webapps/wiki/wiki.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel hashtables calendar namespaces splitting sequences sorting math.order -html.components rss +html.components syndication http.server http.server.dispatchers furnace @@ -10,7 +10,7 @@ furnace.actions furnace.auth furnace.auth.login furnace.boilerplate -furnace.rss +furnace.syndication validators db.types db.tuples lcs farkup urls ; IN: webapps.wiki From 4dfa3546736517d7a08fd7617dfb8c5a8bb503e9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 5 Jun 2008 02:42:36 -0500 Subject: [PATCH 50/71] Fix wiki links on revision view pages, and remove obsolete templates --- extra/webapps/planet/entry-summary.xml | 10 ---------- extra/webapps/planet/entry.xml | 17 ----------------- extra/webapps/wiki/wiki.factor | 1 + 3 files changed, 1 insertion(+), 27 deletions(-) delete mode 100644 extra/webapps/planet/entry-summary.xml delete mode 100644 extra/webapps/planet/entry.xml diff --git a/extra/webapps/planet/entry-summary.xml b/extra/webapps/planet/entry-summary.xml deleted file mode 100644 index 70274d67d9..0000000000 --- a/extra/webapps/planet/entry-summary.xml +++ /dev/null @@ -1,10 +0,0 @@ - - - - -

    -
    - Read More... -

    - -     diff --git a/extra/webapps/planet/entry.xml b/extra/webapps/planet/entry.xml deleted file mode 100644 index 01fda67316..0000000000 --- a/extra/webapps/planet/entry.xml +++ /dev/null @@ -1,17 +0,0 @@ - - - - -

    - -

    - -

    - -

    - -

    - -

    - -     diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor index dbba4dac08..611bba4c70 100644 --- a/extra/webapps/wiki/wiki.factor +++ b/extra/webapps/wiki/wiki.factor @@ -104,6 +104,7 @@ M: revision feed-entry-url id>> revision-url ; validate-integer-id "id" value select-tuple from-object + "view?title=" relative-link-prefix set ] >>init { wiki "view" } >>template ; From 8199a19571a68cf5de7e5d08830dd8eef25db2c1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 5 Jun 2008 02:42:44 -0500 Subject: [PATCH 51/71] Inference fix --- extra/pango/cairo/gadgets/gadgets.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/pango/cairo/gadgets/gadgets.factor b/extra/pango/cairo/gadgets/gadgets.factor index 4c46b4e501..118ed76afc 100644 --- a/extra/pango/cairo/gadgets/gadgets.factor +++ b/extra/pango/cairo/gadgets/gadgets.factor @@ -33,7 +33,7 @@ TUPLE: pango-gadget < cairo-gadget text font ; swap >>font ; : setup-layout ( {font,text} -- quot ) - first2 '[ , layout-font , layout-text ] ; + first2 '[ , layout-font , layout-text ] ; inline M: pango-gadget quot>> ( gadget -- quot ) cache-key setup-layout [ show-layout ] compose From 7372423e4b70248f06e95685de042442859dc45f Mon Sep 17 00:00:00 2001 From: James Cash Date: Wed, 4 Jun 2008 12:47:53 -0400 Subject: [PATCH 52/71] Working on quasi-quoted forms --- extra/lisp/lisp.factor | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor index 616efcbb1d..00d7b3cf95 100644 --- a/extra/lisp/lisp.factor +++ b/extra/lisp/lisp.factor @@ -60,10 +60,18 @@ PRIVATE> : convert-quoted ( cons -- quot ) cdr 1quotation ; +: convert-unquoted ( cons -- quot ) + "unquote not valid outside of quasiquote!" throw ; + +: convert-quasiquoted ( cons -- newcons ) + [ ] traverse ; + : form-dispatch ( lisp-symbol -- quot ) name>> { { "lambda" [ convert-lambda ] } { "quote" [ convert-quoted ] } + { "unquote" [ convert-unquoted ] } + { "quasiquote" [ convert-quasiquoted ] } { "if" [ convert-if ] } { "begin" [ convert-begin ] } { "cond" [ convert-cond ] } @@ -125,4 +133,4 @@ M: no-such-var summary drop "No such variable" ; name>> macro-env get at ; : lisp-macro? ( car -- ? ) - dup lisp-symbol? [ name>> macro-env get key? ] [ drop f ] if ; \ No newline at end of file + dup lisp-symbol? [ name>> macro-env get key? ] [ drop f ] if ; From 6e174706af839b750de574a1a1b0323df53c6f40 Mon Sep 17 00:00:00 2001 From: James Cash Date: Thu, 5 Jun 2008 04:13:51 -0400 Subject: [PATCH 53/71] Re-implementing and renaming several words in lists --- extra/lists/lazy/lazy-docs.factor | 2 +- extra/lists/lists-docs.factor | 44 +++++++++++++++++++++--- extra/lists/lists-tests.factor | 22 +++++++++--- extra/lists/lists.factor | 56 ++++++++++++++++++++++--------- 4 files changed, 98 insertions(+), 26 deletions(-) diff --git a/extra/lists/lazy/lazy-docs.factor b/extra/lists/lazy/lazy-docs.factor index f2b03fe108..8d457ba2e1 100644 --- a/extra/lists/lazy/lazy-docs.factor +++ b/extra/lists/lazy/lazy-docs.factor @@ -86,7 +86,7 @@ HELP: >list { $description "Convert the object into a list. Existing lists are passed through intact, sequences are converted using " { $link seq>list } " and other objects cause an error to be thrown." } { $see-also seq>list } ; -{ leach lreduce lazy-map lazy-map-with ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lreduce lwhile luntil } related-words +{ leach foldl lazy-map lazy-map-with ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lwhile luntil } related-words HELP: lconcat { $values { "list" "a list of lists" } { "result" "a list" } } diff --git a/extra/lists/lists-docs.factor b/extra/lists/lists-docs.factor index 51b068d979..6b22e77121 100644 --- a/extra/lists/lists-docs.factor +++ b/extra/lists/lists-docs.factor @@ -17,7 +17,7 @@ HELP: car HELP: cdr { $values { "cons" "a cons object" } { "cdr" "a cons object" } } { $description "Returns the tail of the list." } ; - + HELP: nil { $values { "cons" "An empty cons" } } { $description "Returns a representation of an empty list" } ; @@ -55,16 +55,50 @@ HELP: llength { $see-also lnth cons car cdr } ; HELP: uncons -{ $values { "cons" "a cons object" } { "car" "the head of the list" } { "cdr" "the tail of the list" } } +{ $values { "cons" "a cons object" } { "cdr" "the tail of the list" } { "car" "the head of the list" } } { $description "Put the head and tail of the list on the stack." } ; -{ leach lreduce lmap>array } related-words +{ leach foldl lmap>array } related-words HELP: leach { $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( obj -- )" } } { $description "Call the quotation for each item in the list." } ; -HELP: lreduce +HELP: foldl { $values { "list" "a cons object" } { "identity" "an object" } { "quot" "a quotation with stack effect ( prev elt -- next )" } { "result" "the final result" } } -{ $description "Combines successive elements of the list using a binary operation, and outputs the final result." } ; +{ $description "Combines successive elements of the list (in a left-assocative order) using a binary operation and outputs the final result." } ; +HELP: foldr +{ $values { "list" "a cons object" } { "identity" "an object" } { "quot" "a quotation with stack effect ( prev elt -- next )" } { "result" "the final result" } } +{ $description "Combines successive elements of the list (in a right-assocative order) using a binary operation, and outputs the final result." } ; + +HELP: lmap +{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( old -- new )" } { "result" "the final result" } } +{ $description "Applies the quotation to each element of the list in order, collecting the new elements into a new list." } ; + +HELP: lreverse +{ $values { "list" "a cons object" } { "newlist" "a new cons object" } } +{ $description "Reverses the input list, outputing a new, reversed list" } ; + +HELP: list>seq +{ $values { "list" "a cons object" } { "array" "an array object" } } +{ $description "Turns the given cons object into an array, maintaing order." } ; + +HELP: seq>list +{ $values { "array" "an array object" } { "list" "a cons object" } } +{ $description "Turns the given array into a cons object, maintaing order." } ; + +HELP: cons>seq +{ $values { "cons" "a cons object" } { "array" "an array object" } } +{ $description "Recursively turns the given cons object into an array, maintaing order and also converting nested lists." } ; + +HELP: seq>cons +{ $values { "seq" "a sequence object" } { "cons" "a cons object" } } +{ $description "Recursively turns the given sequence into a cons object, maintaing order and also converting nested lists." } ; + +HELP: traverse +{ $values { " list" "a cons object" } { "pred" } { "a quotation with stack effect ( list/elt -- ? )" } + { "quot" "a quotation with stack effect ( list/elt -- result)" } { "result" "a new cons object" } } +{ $description "Recursively traverses the list object, replacing any elements (which can themselves be sublists) that " { $snippet pred } + " returns true for with the result of applying " { $snippet quot } " to." } ; + diff --git a/extra/lists/lists-tests.factor b/extra/lists/lists-tests.factor index 0abb8befeb..1f86379fab 100644 --- a/extra/lists/lists-tests.factor +++ b/extra/lists/lists-tests.factor @@ -4,6 +4,10 @@ USING: tools.test lists math ; IN: lists.tests +{ { 3 4 5 6 7 } } [ + { 1 2 3 4 5 } seq>list [ 2 + ] lmap list>seq +] unit-test + { { 3 4 5 6 } } [ T{ cons f 1 T{ cons f 2 @@ -17,7 +21,7 @@ IN: lists.tests T{ cons f 2 T{ cons f 3 T{ cons f 4 - +nil+ } } } } 0 [ + ] lreduce + +nil+ } } } } 0 [ + ] foldl ] unit-test { T{ cons f @@ -38,13 +42,21 @@ IN: lists.tests ] unit-test { { 1 2 { 3 4 { 5 } } } } [ - { 1 2 { 3 4 { 5 } } } seq>cons cons>seq + { 1 2 { 3 4 { 5 } } } seq>cons cons>seq ] unit-test { T{ cons f 2 T{ cons f 3 T{ cons f 4 T{ cons f 5 +nil+ } } } } } [ { 1 2 3 4 } seq>cons [ 1+ ] lmap ] unit-test -! { { 3 4 { 5 6 { 7 } } } } [ -! { 1 2 { 3 4 { 5 } } } seq>cons [ 2 + ] traverse cons>seq -! ] unit-test \ No newline at end of file +{ 15 } [ + { 1 2 3 4 5 } seq>list 0 [ + ] foldr +] unit-test + +{ { 5 4 3 2 1 } } [ + { 1 2 3 4 5 } seq>list lreverse list>seq +] unit-test + +{ { 3 4 { 5 6 { 7 } } } } [ + { 1 2 { 3 4 { 5 } } } seq>cons [ atom? ] [ 2 + ] traverse cons>seq +] unit-test \ No newline at end of file diff --git a/extra/lists/lists.factor b/extra/lists/lists.factor index b0fd41fe75..a04a728ffc 100644 --- a/extra/lists/lists.factor +++ b/extra/lists/lists.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Chris Double & James Cash ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences accessors math arrays vectors classes words ; +USING: kernel sequences accessors math arrays vectors classes words locals ; IN: lists @@ -23,6 +23,8 @@ M: cons cdr ( cons -- cdr ) SYMBOL: +nil+ M: word nil? +nil+ eq? ; M: object nil? drop f ; + +: atom? ( obj -- ? ) [ list? ] [ nil? ] bi or not ; : nil ( -- +nil+ ) +nil+ ; @@ -38,6 +40,9 @@ M: object nil? drop f ; : 3list ( a b c -- cons ) nil cons cons cons ; +: cadr ( cons -- elt ) + cdr car ; + : 2car ( cons -- car caar ) [ car ] [ cdr car ] bi ; @@ -52,12 +57,38 @@ M: object nil? drop f ; : llength ( list -- n ) 0 (llength) ; + +: (leach) ( list quot -- cdr quot ) + [ [ car ] dip call ] [ [ cdr ] dip ] 2bi ; inline : leach ( list quot -- ) - over nil? [ 2drop ] [ [ uncons swap ] dip tuck [ call ] 2dip leach ] if ; inline + over nil? [ 2drop ] [ (leach) leach ] if ; inline + +: lmap ( list quot -- result ) + over nil? [ drop ] [ (leach) lmap cons ] if ; inline + +: foldl ( list ident quot -- result ) swapd leach ; inline + +: foldr ( list ident quot -- result ) + pick nil? [ [ drop ] [ ] [ drop ] tri* ] [ + [ [ cdr ] 2dip foldr ] [ nip [ car ] dip ] 3bi + call + ] if ; inline -: lreduce ( list identity quot -- result ) - swapd leach ; inline +: lreverse ( list -- newlist ) + nil [ swap cons ] foldl ; + +: lappend ( list1 list2 -- newlist ) + ; + +: seq>list ( seq -- list ) + nil [ swap cons ] reduce ; + +: same? ( obj1 obj2 -- ? ) + [ class ] bi@ = ; + +: seq>cons ( seq -- cons ) + [ ] keep nil [ tuck same? [ seq>cons ] when f cons swap >>cdr ] with reduce ; : (lmap>array) ( acc cons quot -- newcons ) over nil? [ 2drop ] @@ -69,19 +100,14 @@ M: object nil? drop f ; : lmap-as ( cons quot exemplar -- seq ) [ lmap>array ] dip like ; -: lmap ( list quot -- newlist ) - lmap>array nil [ swap cons ] reduce ; - -: same? ( obj1 obj2 -- ? ) - [ class ] bi@ = ; - -: seq>cons ( seq -- cons ) - [ ] keep nil [ tuck same? [ seq>cons ] when f cons swap >>cdr ] with reduce ; - : cons>seq ( cons -- array ) [ dup cons? [ cons>seq ] when ] lmap>array ; -: traverse ( list quot -- newlist ) - [ over list? [ traverse ] [ call ] if ] curry lmap ; +: list>seq ( list -- array ) + [ ] lmap>array ; + +: traverse ( list pred quot -- result ) + [ 2over call [ tuck [ call ] 2dip ] when + pick list? [ traverse ] [ 2drop ] if ] 2curry lmap ; INSTANCE: cons list \ No newline at end of file From be4cc36e127e9079410dc756666148b0373e033b Mon Sep 17 00:00:00 2001 From: James Cash Date: Thu, 5 Jun 2008 04:14:26 -0400 Subject: [PATCH 54/71] Implementing quasiquotes for lisp --- extra/lisp/lisp.factor | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor index 00d7b3cf95..6193c3b33e 100644 --- a/extra/lisp/lisp.factor +++ b/extra/lisp/lisp.factor @@ -16,7 +16,7 @@ DEFER: macro-call ! Functions to convert s-exps to quotations ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : convert-body ( cons -- quot ) - [ ] [ convert-form compose ] lreduce ; inline + [ ] [ convert-form compose ] foldl ; inline : convert-if ( cons -- quot ) cdr 3car [ convert-form ] tri@ '[ @ , , if ] ; @@ -64,7 +64,8 @@ PRIVATE> "unquote not valid outside of quasiquote!" throw ; : convert-quasiquoted ( cons -- newcons ) - [ ] traverse ; + [ { [ dup list? ] [ car dup lisp-symbol? ] [ name>> "unquote" equal? dup ] } && nip ] + [ cadr ] traverse ; : form-dispatch ( lisp-symbol -- quot ) name>> From c901734689c862653e31eb4b0849e6d082ab4da8 Mon Sep 17 00:00:00 2001 From: James Cash Date: Thu, 5 Jun 2008 14:31:15 -0400 Subject: [PATCH 55/71] Fixing bug in nil? --- extra/lists/lazy/lazy.factor | 14 ++++++-------- 1 file changed, 6 insertions(+), 8 deletions(-) diff --git a/extra/lists/lazy/lazy.factor b/extra/lists/lazy/lazy.factor index 03e5b0f8cc..6beb6e402d 100644 --- a/extra/lists/lazy/lazy.factor +++ b/extra/lists/lazy/lazy.factor @@ -72,7 +72,7 @@ M: memoized-cons cdr ( memoized-cons -- cdr ) M: memoized-cons nil? ( memoized-cons -- bool ) dup nil?>> not-memoized? [ - dup original>> nil? [ >>nil? drop ] keep + dup original>> nil? [ >>nil? drop ] keep ] [ nil?>> ] if ; @@ -157,22 +157,20 @@ TUPLE: lazy-filter cons quot ; C: lazy-filter : lfilter ( list quot -- result ) - over nil? [ 2drop nil ] [ ] if ; + over nil? [ 2drop nil ] [ ] if ; -: car-filter? ( lazy-filter -- ? ) - [ cons>> car ] keep - quot>> call ; +: car-filter? ( lazy-filter -- ? ) + [ cons>> car ] [ quot>> ] bi call ; : skip ( lazy-filter -- ) - dup cons>> cdr >>cons ; + dup cons>> cdr >>cons drop ; M: lazy-filter car ( lazy-filter -- car ) dup car-filter? [ cons>> ] [ dup skip ] if car ; M: lazy-filter cdr ( lazy-filter -- cdr ) dup car-filter? [ - [ cons>> cdr ] keep - quot>> lfilter + [ cons>> cdr ] [ quot>> ] bi lfilter ] [ dup skip cdr ] if ; From 9a0027126d497651c95d5328e70bd1a676f5a99e Mon Sep 17 00:00:00 2001 From: James Cash Date: Thu, 5 Jun 2008 14:31:43 -0400 Subject: [PATCH 56/71] Fixing typos in lists-docs --- extra/lists/lists-docs.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/lists/lists-docs.factor b/extra/lists/lists-docs.factor index 6b22e77121..a5299ba6a0 100644 --- a/extra/lists/lists-docs.factor +++ b/extra/lists/lists-docs.factor @@ -99,6 +99,6 @@ HELP: seq>cons HELP: traverse { $values { " list" "a cons object" } { "pred" } { "a quotation with stack effect ( list/elt -- ? )" } { "quot" "a quotation with stack effect ( list/elt -- result)" } { "result" "a new cons object" } } -{ $description "Recursively traverses the list object, replacing any elements (which can themselves be sublists) that " { $snippet pred } - " returns true for with the result of applying " { $snippet quot } " to." } ; +{ $description "Recursively traverses the list object, replacing any elements (which can themselves be sublists) that pred" + " returns true for with the result of applying quot to." } ; From 66318073931c5cbb6ccadbe53c55ba456d979dd3 Mon Sep 17 00:00:00 2001 From: James Cash Date: Thu, 5 Jun 2008 14:32:03 -0400 Subject: [PATCH 57/71] Adding tests to lists --- extra/lists/lists-tests.factor | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/extra/lists/lists-tests.factor b/extra/lists/lists-tests.factor index 1f86379fab..cdc51b76e8 100644 --- a/extra/lists/lists-tests.factor +++ b/extra/lists/lists-tests.factor @@ -57,6 +57,10 @@ IN: lists.tests { 1 2 3 4 5 } seq>list lreverse list>seq ] unit-test +{ 5 } [ + { 1 2 3 4 5 } seq>list llength +] unit-test + { { 3 4 { 5 6 { 7 } } } } [ { 1 2 { 3 4 { 5 } } } seq>cons [ atom? ] [ 2 + ] traverse cons>seq ] unit-test \ No newline at end of file From 706146847369b41075495ffa43d8df21f56b8abf Mon Sep 17 00:00:00 2001 From: James Cash Date: Thu, 5 Jun 2008 14:32:43 -0400 Subject: [PATCH 58/71] Rewriting llength in terms of folds --- extra/lists/lists.factor | 12 +++--------- 1 file changed, 3 insertions(+), 9 deletions(-) diff --git a/extra/lists/lists.factor b/extra/lists/lists.factor index a04a728ffc..30a234214b 100644 --- a/extra/lists/lists.factor +++ b/extra/lists/lists.factor @@ -51,12 +51,6 @@ M: object nil? drop f ; : lnth ( n list -- elt ) swap [ cdr ] times car ; - -: (llength) ( list acc -- n ) - over nil? [ nip ] [ [ cdr ] dip 1+ (llength) ] if ; - -: llength ( list -- n ) - 0 (llength) ; : (leach) ( list quot -- cdr quot ) [ [ car ] dip call ] [ [ cdr ] dip ] 2bi ; inline @@ -74,13 +68,13 @@ M: object nil? drop f ; [ [ cdr ] 2dip foldr ] [ nip [ car ] dip ] 3bi call ] if ; inline + +: llength ( list -- n ) + 0 [ drop 1+ ] foldl ; : lreverse ( list -- newlist ) nil [ swap cons ] foldl ; -: lappend ( list1 list2 -- newlist ) - ; - : seq>list ( seq -- list ) nil [ swap cons ] reduce ; From b494a18b9e377eb3326eb99e7b2ee9a5f93bae31 Mon Sep 17 00:00:00 2001 From: James Cash Date: Thu, 5 Jun 2008 16:28:24 -0400 Subject: [PATCH 59/71] Adding tests for macros now --- extra/lisp/lisp-tests.factor | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/extra/lisp/lisp-tests.factor b/extra/lisp/lisp-tests.factor index 2603a75cb0..a6016f2697 100644 --- a/extra/lisp/lisp-tests.factor +++ b/extra/lisp/lisp-tests.factor @@ -31,6 +31,10 @@ IN: lisp.test "((lambda (x y z) (+ x (- y z))) 40 3 1)" lisp-eval ] unit-test + { T{ lisp-symbol f "if" } } [ + "(defmacro if (pred tr fl) (quasiquote (cond ((unquote pred) (unquote tr)) (#t (unquote fl)))))" lisp-eval + ] unit-test + { 1 } [ "(if #t 1 2)" lisp-eval ] unit-test From b53302a0ca670287ffdee3e746c8fccdd1d73cf1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 5 Jun 2008 15:29:38 -0500 Subject: [PATCH 60/71] Documentation fixes --- core/assocs/assocs-docs.factor | 2 +- core/syntax/syntax-docs.factor | 3 +++ 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/core/assocs/assocs-docs.factor b/core/assocs/assocs-docs.factor index 68be9c9b06..d660436783 100755 --- a/core/assocs/assocs-docs.factor +++ b/core/assocs/assocs-docs.factor @@ -139,7 +139,7 @@ HELP: new-assoc HELP: assoc-find { $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "key" "the successful key, or f" } { "value" "the successful value, or f" } { "?" "a boolean" } } -{ $contract "Applies a predicate quotation to each entry in the assoc. Returns the key or value that the quotation succeeds on, or " { $link f } " for both if the quotation fails. It also returns a boolean describing whether there was anything found." } +{ $contract "Applies a predicate quotation to each entry in the assoc. Returns the key and value that the quotation succeeds on, or " { $link f } " for both if the quotation fails. It also returns a boolean describing whether there was anything found; this can be used to distinguish between a key and a value equal to " { $link f } ", or nothing being found." } { $notes "The " { $link assoc } " mixin has a default implementation for this generic word which first converts the assoc to an association list, then iterates over that with the " { $link find } " combinator for sequences." } ; HELP: clear-assoc diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index 18595aaab3..314d9697e7 100755 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -526,6 +526,9 @@ HELP: PREDICATE: "it satisfies the predicate" } "Each predicate must be defined as a subclass of some other class. This ensures that predicates inheriting from disjoint classes do not need to be exhaustively tested during method dispatch." +} +{ $examples + { $code "USING: math ;" "PREDICATE: positive < integer 0 > ;" } } ; HELP: TUPLE: From 35e2bb8711bdacf3dedac1cb0410fa33f7bf9836 Mon Sep 17 00:00:00 2001 From: James Cash Date: Thu, 5 Jun 2008 18:14:43 -0400 Subject: [PATCH 61/71] More macro tests --- extra/lisp/lisp-tests.factor | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/extra/lisp/lisp-tests.factor b/extra/lisp/lisp-tests.factor index a6016f2697..c4090e1098 100644 --- a/extra/lisp/lisp-tests.factor +++ b/extra/lisp/lisp-tests.factor @@ -7,8 +7,8 @@ IN: lisp.test [ init-env - "#f" [ f ] lisp-define - "#t" [ t ] lisp-define + [ f ] "#f" lisp-define + [ t ] "#t" lisp-define "+" "math" "+" define-primitive "-" "math" "-" define-primitive @@ -35,6 +35,10 @@ IN: lisp.test "(defmacro if (pred tr fl) (quasiquote (cond ((unquote pred) (unquote tr)) (#t (unquote fl)))))" lisp-eval ] unit-test + { t } [ + T{ lisp-symbol f "if" } lisp-macro? + ] unit-test + { 1 } [ "(if #t 1 2)" lisp-eval ] unit-test From 60db47acf4f1f8e72ffc528f3d69d71fef042e64 Mon Sep 17 00:00:00 2001 From: James Cash Date: Thu, 5 Jun 2008 18:15:05 -0400 Subject: [PATCH 62/71] Macros almost working --- extra/lisp/lisp.factor | 56 ++++++++++++++++++++++++------------------ 1 file changed, 32 insertions(+), 24 deletions(-) diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor index 6193c3b33e..b64957b2c5 100644 --- a/extra/lisp/lisp.factor +++ b/extra/lisp/lisp.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel peg sequences arrays strings combinators.lib namespaces combinators math locals locals.private accessors -vectors syntax lisp.parser assocs parser sequences.lib words quotations -fry lists inspector ; +vectors syntax lisp.parser assocs parser sequences.lib words +quotations fry lists inspector ; IN: lisp DEFER: convert-form @@ -11,15 +11,13 @@ DEFER: funcall DEFER: lookup-var DEFER: lisp-macro? DEFER: lookup-macro -DEFER: macro-call - +DEFER: macro-expand +DEFER: define-lisp-macro + ! Functions to convert s-exps to quotations ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : convert-body ( cons -- quot ) [ ] [ convert-form compose ] foldl ; inline - -: convert-if ( cons -- quot ) - cdr 3car [ convert-form ] tri@ '[ @ , , if ] ; : convert-begin ( cons -- quot ) cdr [ convert-form ] [ ] lmap-as '[ , [ funcall ] each ] ; @@ -34,13 +32,11 @@ DEFER: macro-call ! words for convert-lambda > swap at swap or ] - [ dup cons? [ localize-body ] when nip ] if - ] with lmap>array ; - + [ lisp-symbol? ] pick '[ [ name>> , at ] [ ] bi or ] traverse ; + : localize-lambda ( body vars -- newbody newvars ) make-locals dup push-locals swap - [ swap localize-body seq>cons convert-form swap pop-locals ] dip swap ; + [ swap localize-body convert-form swap pop-locals ] dip swap ; : split-lambda ( cons -- body-cons vars-seq ) 3car -rot nip [ name>> ] lmap>array ; inline @@ -67,24 +63,24 @@ PRIVATE> [ { [ dup list? ] [ car dup lisp-symbol? ] [ name>> "unquote" equal? dup ] } && nip ] [ cadr ] traverse ; -: form-dispatch ( lisp-symbol -- quot ) +: convert-defmacro ( cons -- quot ) + cdr [ car ] keep [ convert-lambda ] [ car name>> ] bi define-lisp-macro 1quotation ; + +: form-dispatch ( cons lisp-symbol -- quot ) name>> { { "lambda" [ convert-lambda ] } + { "defmacro" [ convert-defmacro ] } { "quote" [ convert-quoted ] } { "unquote" [ convert-unquoted ] } { "quasiquote" [ convert-quasiquoted ] } - { "if" [ convert-if ] } { "begin" [ convert-begin ] } { "cond" [ convert-cond ] } [ drop convert-general-form ] } case ; -: macro-expand ( cons -- quot ) - uncons lookup-macro macro-call convert-form ; - : convert-list-form ( cons -- quot ) dup car - { { [ dup lisp-macro? ] [ macro-expand ] } + { { [ dup lisp-macro? ] [ drop macro-expand ] } { [ dup lisp-symbol? ] [ form-dispatch ] } [ drop convert-general-form ] } cond ; @@ -96,8 +92,17 @@ PRIVATE> [ 1quotation ] } cond ; +: compile-form ( lisp-ast -- quot ) + convert-form lambda-rewrite call ; inline + +: macro-call ( lambda -- cons ) + call ; + +: macro-expand ( cons -- quot ) + uncons lookup-macro macro-call compile-form ; + : lisp-string>factor ( str -- quot ) - lisp-expr parse-result-ast convert-form lambda-rewrite call ; + lisp-expr parse-result-ast compile-form ; : lisp-eval ( str -- * ) lisp-string>factor call ; @@ -105,7 +110,7 @@ PRIVATE> ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! SYMBOL: lisp-env -ERROR: no-such-var var ; +ERROR: no-such-var variable-name ; SYMBOL: macro-env @@ -115,8 +120,8 @@ M: no-such-var summary drop "No such variable" ; H{ } clone lisp-env set H{ } clone macro-env set ; -: lisp-define ( name quot -- ) - swap lisp-env get set-at ; +: lisp-define ( quot name -- ) + lisp-env get set-at ; : lisp-get ( name -- word ) dup lisp-env get at [ ] [ no-such-var ] ?if ; @@ -128,10 +133,13 @@ M: no-such-var summary drop "No such variable" ; dup lisp-symbol? [ lookup-var ] when call ; inline : define-primitive ( name vocab word -- ) - swap lookup 1quotation '[ , compose call ] lisp-define ; + swap lookup 1quotation '[ , compose call ] swap lisp-define ; -: lookup-macro ( lisp-symbol -- macro ) +: lookup-macro ( lisp-symbol -- lambda ) name>> macro-env get at ; +: define-lisp-macro ( quot name -- ) + macro-env get set-at ; + : lisp-macro? ( car -- ? ) dup lisp-symbol? [ name>> macro-env get key? ] [ drop f ] if ; From 90905c2519f6e9bd929e23ec142d5134eaef1a3c Mon Sep 17 00:00:00 2001 From: James Cash Date: Thu, 5 Jun 2008 18:53:44 -0400 Subject: [PATCH 63/71] Fixing remaining lazy-lists, to lists.lazy --- extra/lists/lazy/examples/examples.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/lists/lazy/examples/examples.factor b/extra/lists/lazy/examples/examples.factor index 9e8fb77439..f85344651d 100644 --- a/extra/lists/lazy/examples/examples.factor +++ b/extra/lists/lazy/examples/examples.factor @@ -2,8 +2,8 @@ ! Copyright (C) 2004 Chris Double. ! See http://factorcode.org/license.txt for BSD license. -USING: lazy-lists math kernel sequences quotations ; -IN: lazy-lists.examples +USING: lists.lazy math kernel sequences quotations ; +IN: lists.lazy.examples : naturals 0 lfrom ; : positives 1 lfrom ; From 50b76dbe269d050e6c3f60fbc185b1010865bf8a Mon Sep 17 00:00:00 2001 From: James Cash Date: Thu, 5 Jun 2008 18:53:58 -0400 Subject: [PATCH 64/71] Fixing docs for lists --- extra/lists/lazy/lazy-docs.factor | 1 - extra/lists/lists-docs.factor | 8 ++++---- 2 files changed, 4 insertions(+), 5 deletions(-) diff --git a/extra/lists/lazy/lazy-docs.factor b/extra/lists/lazy/lazy-docs.factor index 8d457ba2e1..95e925b089 100644 --- a/extra/lists/lazy/lazy-docs.factor +++ b/extra/lists/lazy/lazy-docs.factor @@ -127,4 +127,3 @@ HELP: llines { $values { "stream" "a stream" } { "result" "a list" } } { $description "Returns a lazy list of all lines in the file. " { $link car } " returns the next lines in the file, " { $link cdr } " returns the remaining lines as a lazy list. " { $link nil? } " indicates end of file." } { $see-also lcontents } ; - diff --git a/extra/lists/lists-docs.factor b/extra/lists/lists-docs.factor index a5299ba6a0..15faf8d002 100644 --- a/extra/lists/lists-docs.factor +++ b/extra/lists/lists-docs.factor @@ -19,8 +19,8 @@ HELP: cdr { $description "Returns the tail of the list." } ; HELP: nil -{ $values { "cons" "An empty cons" } } -{ $description "Returns a representation of an empty list" } ; +{ $values { "symbol" "The empty cons (+nil+)" } } +{ $description "Returns a symbol representing the empty list" } ; HELP: nil? { $values { "cons" "a cons object" } { "?" "a boolean" } } @@ -85,7 +85,7 @@ HELP: list>seq { $description "Turns the given cons object into an array, maintaing order." } ; HELP: seq>list -{ $values { "array" "an array object" } { "list" "a cons object" } } +{ $values { "seq" "a sequence" } { "list" "a cons object" } } { $description "Turns the given array into a cons object, maintaing order." } ; HELP: cons>seq @@ -97,7 +97,7 @@ HELP: seq>cons { $description "Recursively turns the given sequence into a cons object, maintaing order and also converting nested lists." } ; HELP: traverse -{ $values { " list" "a cons object" } { "pred" } { "a quotation with stack effect ( list/elt -- ? )" } +{ $values { "list" "a cons object" } { "pred" "a quotation with stack effect ( list/elt -- ? )" } { "quot" "a quotation with stack effect ( list/elt -- result)" } { "result" "a new cons object" } } { $description "Recursively traverses the list object, replacing any elements (which can themselves be sublists) that pred" " returns true for with the result of applying quot to." } ; From 887b385250b31b3af7b2f6a7e703759b1aaef3ee Mon Sep 17 00:00:00 2001 From: James Cash Date: Thu, 5 Jun 2008 19:50:35 -0400 Subject: [PATCH 65/71] De-linting lists and lists.lazy --- extra/lists/lazy/lazy-docs.factor | 2 +- extra/lists/lists.factor | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/extra/lists/lazy/lazy-docs.factor b/extra/lists/lazy/lazy-docs.factor index 95e925b089..6a9359027d 100644 --- a/extra/lists/lazy/lazy-docs.factor +++ b/extra/lists/lazy/lazy-docs.factor @@ -115,7 +115,7 @@ HELP: lmerge { $values { "list1" "a list" } { "list2" "a list" } { "result" "lazy list merging list1 and list2" } } { $description "Return the result of merging the two lists in a lazy manner." } { $examples - { $example "USING: lazy-lists prettyprint ;" "{ 1 2 3 } >list { 4 5 6 } >list lmerge list>array ." "{ 1 4 2 5 3 6 }" } + { $example "USING: lists.lazy prettyprint ;" "{ 1 2 3 } >list { 4 5 6 } >list lmerge list>array ." "{ 1 4 2 5 3 6 }" } } ; HELP: lcontents diff --git a/extra/lists/lists.factor b/extra/lists/lists.factor index 30a234214b..3799d48fff 100644 --- a/extra/lists/lists.factor +++ b/extra/lists/lists.factor @@ -26,7 +26,7 @@ M: object nil? drop f ; : atom? ( obj -- ? ) [ list? ] [ nil? ] bi or not ; -: nil ( -- +nil+ ) +nil+ ; +: nil ( -- symbol ) +nil+ ; : uncons ( cons -- cdr car ) [ cdr ] [ car ] bi ; @@ -61,9 +61,9 @@ M: object nil? drop f ; : lmap ( list quot -- result ) over nil? [ drop ] [ (leach) lmap cons ] if ; inline -: foldl ( list ident quot -- result ) swapd leach ; inline +: foldl ( list identity quot -- result ) swapd leach ; inline -: foldr ( list ident quot -- result ) +: foldr ( list identity quot -- result ) pick nil? [ [ drop ] [ ] [ drop ] tri* ] [ [ [ cdr ] 2dip foldr ] [ nip [ car ] dip ] 3bi call From 9a0484b3a5862634325f1401fc2eabab1864d7ce Mon Sep 17 00:00:00 2001 From: James Cash Date: Thu, 5 Jun 2008 20:38:12 -0400 Subject: [PATCH 66/71] Minor edits --- extra/lisp/lisp.factor | 5 ++--- extra/lists/lists.factor | 2 +- 2 files changed, 3 insertions(+), 4 deletions(-) diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor index b64957b2c5..6c9aa3eb73 100644 --- a/extra/lisp/lisp.factor +++ b/extra/lisp/lisp.factor @@ -9,8 +9,8 @@ IN: lisp DEFER: convert-form DEFER: funcall DEFER: lookup-var -DEFER: lisp-macro? DEFER: lookup-macro +DEFER: lisp-macro? DEFER: macro-expand DEFER: define-lisp-macro @@ -110,10 +110,9 @@ PRIVATE> ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! SYMBOL: lisp-env -ERROR: no-such-var variable-name ; - SYMBOL: macro-env +ERROR: no-such-var variable-name ; M: no-such-var summary drop "No such variable" ; : init-env ( -- ) diff --git a/extra/lists/lists.factor b/extra/lists/lists.factor index 3799d48fff..13d77f757a 100644 --- a/extra/lists/lists.factor +++ b/extra/lists/lists.factor @@ -8,7 +8,7 @@ IN: lists MIXIN: list GENERIC: car ( cons -- car ) GENERIC: cdr ( cons -- cdr ) -GENERIC: nil? ( cons -- ? ) +GENERIC: nil? ( object -- ? ) TUPLE: cons car cdr ; From b64a115226b4b13f17c3f18a0f91bc5049577b9e Mon Sep 17 00:00:00 2001 From: James Cash Date: Fri, 6 Jun 2008 00:29:22 -0400 Subject: [PATCH 67/71] More refactorings to lisp --- extra/lisp/lisp.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor index 6c9aa3eb73..e865a2e3ed 100644 --- a/extra/lisp/lisp.factor +++ b/extra/lisp/lisp.factor @@ -96,10 +96,10 @@ PRIVATE> convert-form lambda-rewrite call ; inline : macro-call ( lambda -- cons ) - call ; + call ; inline : macro-expand ( cons -- quot ) - uncons lookup-macro macro-call compile-form ; + uncons [ list>seq [ ] like ] [ lookup-macro macro-call compile-form ] bi* call ; : lisp-string>factor ( str -- quot ) lisp-expr parse-result-ast compile-form ; From 58dd8893794ff38ef3c665a91519c81cae4ec358 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 6 Jun 2008 01:53:47 -0500 Subject: [PATCH 68/71] PersistentVectors from Clojure --- extra/persistent-vectors/authors.txt | 1 + .../persistent-vectors-docs.factor | 53 +++++ .../persistent-vectors-tests.factor | 63 ++++++ .../persistent-vectors.factor | 185 ++++++++++++++++++ extra/persistent-vectors/summary.txt | 1 + extra/persistent-vectors/tags.txt | 1 + 6 files changed, 304 insertions(+) create mode 100644 extra/persistent-vectors/authors.txt create mode 100644 extra/persistent-vectors/persistent-vectors-docs.factor create mode 100644 extra/persistent-vectors/persistent-vectors-tests.factor create mode 100644 extra/persistent-vectors/persistent-vectors.factor create mode 100644 extra/persistent-vectors/summary.txt create mode 100644 extra/persistent-vectors/tags.txt diff --git a/extra/persistent-vectors/authors.txt b/extra/persistent-vectors/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/persistent-vectors/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/persistent-vectors/persistent-vectors-docs.factor b/extra/persistent-vectors/persistent-vectors-docs.factor new file mode 100644 index 0000000000..b0cb512d43 --- /dev/null +++ b/extra/persistent-vectors/persistent-vectors-docs.factor @@ -0,0 +1,53 @@ +USING: help.markup help.syntax kernel math sequences ; +IN: persistent-vectors + +HELP: new-nth +{ $values { "val" object } { "i" integer } { "seq" sequence } } +{ $contract "Persistent analogue of " { $link set-nth } ". Outputs a new sequence with the " { $snippet "i" } "th element replaced by " { $snippet "val" } "." } +{ $notes "This operation runs in " { $snippet "O(log_32 n)" } " time on " { $link persistent-vector } " instances and " { $snippet "O(n)" } " time on all other sequences." } ; + +HELP: ppush +{ $values { "val" object } { "i" integer } { "seq" sequence } } +{ $contract "Persistent analogue of " { $link push } ". Outputs a new sequence with all elements of " { $snippet "seq" } " together with " { $snippet "val" } " added at the end." } +{ $notes "This operation runs in amortized " { $snippet "O(1)" } " time on " { $link persistent-vector } " instances and " { $snippet "O(n)" } " time on all other sequences." } ; + +HELP: ppop +{ $values { "val" object } { "i" integer } { "seq" sequence } } +{ $contract "Persistent analogue of " { $link pop } ". Outputs a new sequence with all elements of " { $snippet "seq" } " except for the final element." } +{ $notes "This operation runs in amortized " { $snippet "O(1)" } " time on " { $link persistent-vector } " instances and " { $snippet "O(n)" } " time on all other sequences." } ; + +HELP: PV{ +{ $syntax "elements... }" } +{ $description "Parses a literal " { $link persistent-vector } "." } ; + +HELP: >persistent-vector +{ $values { "seq" sequence } { "pvec" persistent-vector } } +{ $description "Creates a " { $link persistent-vector } " with the same elements as " { $snippet "seq" } "." } ; + +HELP: persistent-vector +{ $class-description "The class of persistent vectors." } ; + +HELP: pempty +{ $values { "pvec" persistent-vector } } +{ $description "Outputs an empty " { $link persistent-vector } "." } ; + +ARTICLE: "persistent-vectors" "Persistent vectors" +"A " { $emphasis "persistent vector" } " differs from an ordinary vector (" { $link "vectors" } ") in that it is immutable, and all operations yield new persistent vectors instead of modifying inputs. Unlike immutable operations on ordinary sequences, persistent vector operations are efficient and run in sub-linear time." +$nl +"The class of persistent vectors:" +{ $subsection persistent-vector } +"Persistent vectors support the immutable sequence protocol, namely as " { $link length } " and " { $link nth } ", and so can be used with most sequence words (" { $link "sequences" } ")." +$nl +"In addition to standard sequence operations, persistent vectors implement efficient operations specific to them. They run in sub-linear time on persistent vectors, and degrate to linear-time algorithms on ordinary sequences:" +{ $subsection new-nth } +{ $subsection ppush } +{ $subsection ppop } +"The empty persistent vector, used for building up all other persistent vectors:" +{ $subsection pempty } +"Converting a sequence into a persistent vector:" +{ $subsection >persistent-vector } +"Persistent vectors have a literal syntax:" +{ $subsection POSTPONE: PV{ } +"This implementation of persistent vectors is based on the " { $snippet "clojure.lang.PersistentVector" } " class from Rich Hickey's Clojure language for the JVM (" { $url "http://clojure.org" } ")." ; + +ABOUT: "persistent-vectors" diff --git a/extra/persistent-vectors/persistent-vectors-tests.factor b/extra/persistent-vectors/persistent-vectors-tests.factor new file mode 100644 index 0000000000..f871c95e16 --- /dev/null +++ b/extra/persistent-vectors/persistent-vectors-tests.factor @@ -0,0 +1,63 @@ +IN: persistent-vectors.tests +USING: tools.test persistent-vectors sequences kernel arrays +random namespaces vectors math math.order ; + +\ new-nth must-infer +\ ppush must-infer +\ ppop must-infer + +[ 0 ] [ pempty length ] unit-test + +[ 1 ] [ 3 pempty ppush length ] unit-test + +[ 3 ] [ 3 pempty ppush first ] unit-test + +[ PV{ 3 1 3 3 7 } ] [ + pempty { 3 1 3 3 7 } [ swap ppush ] each +] unit-test + +[ { 3 1 3 3 7 } ] [ + pempty { 3 1 3 3 7 } [ swap ppush ] each >array +] unit-test + +{ 100 1060 2000 10000 100000 1000000 } [ + [ t ] swap [ dup >persistent-vector sequence= ] curry unit-test +] each + +[ ] [ 10000 [ drop 16 random-bits ] PV{ } map-as "1" set ] unit-test +[ ] [ "1" get >vector "2" set ] unit-test + +[ t ] [ + 3000 [ + drop + 16 random-bits 10000 random + [ "1" [ new-nth ] change ] + [ "2" [ new-nth ] change ] 2bi + "1" get "2" get sequence= + ] all? +] unit-test + +[ PV{ } ppop ] [ empty-error? ] must-fail-with + +[ t ] [ PV{ 3 } ppop empty? ] unit-test + +[ PV{ 3 7 } ] [ PV{ 3 7 6 } ppop ] unit-test + +[ PV{ 3 7 6 5 } ] [ 5 PV{ 3 7 6 } ppush ] unit-test + +[ ] [ PV{ } "1" set ] unit-test +[ ] [ V{ } clone "2" set ] unit-test + +[ t ] [ + 100 [ + drop + 100 random [ + 16 random-bits [ "1" [ ppush ] change ] [ "2" get push ] bi + ] times + 100 random "1" get length min [ + "1" [ ppop ] change + "2" get pop* + ] times + "1" get "2" get sequence= + ] all? +] unit-test diff --git a/extra/persistent-vectors/persistent-vectors.factor b/extra/persistent-vectors/persistent-vectors.factor new file mode 100644 index 0000000000..6ed43ca0af --- /dev/null +++ b/extra/persistent-vectors/persistent-vectors.factor @@ -0,0 +1,185 @@ +! Based on Clojure's PersistentVector by Rich Hickey. + +USING: math accessors kernel sequences.private sequences arrays +combinators parser prettyprint.backend fry debugger ; +IN: persistent-vectors + +ERROR: empty-error pvec ; + +GENERIC: ppush ( obj seq -- seq' ) + +M: sequence ppush swap suffix ; + +GENERIC: ppop ( seq -- seq' ) + +M: sequence ppop 1 head* ; + +GENERIC: new-nth ( obj i seq -- seq' ) + +M: sequence new-nth clone [ set-nth ] keep ; + +TUPLE: persistent-vector count root tail ; + +M: persistent-vector length count>> ; + +> ] [ tail>> children>> length ] bi - ; + +: node-shift -5 * shift ; inline + +: node-nth ( i node -- obj ) + children>> [ node-mask ] dip nth ; inline + +: body-nth ( i node -- obj ) + dup level>> 0 > [ + [ drop ] [ [ level>> node-shift ] keep node-nth ] 2bi + body-nth + ] [ + node-nth + ] if ; inline + +M: persistent-vector nth-unsafe + 2dup tail-offset >= + [ tail>> node-nth ] [ root>> body-nth ] if ; + +: node-add ( obj node -- node' ) + clone [ ppush ] change-children ; + +: ppush-tail ( obj pvec -- pvec' ) + [ node-add ] change-tail ; + +: full? ( node -- ? ) + children>> length node-size = ; + +: 1node ( obj level -- node ) + node new + swap >>level + swap 1array >>children ; + +: 2node ( first second -- node ) + 2dup [ level>> ] bi@ assert= + [ 2array ] [ drop level>> 1+ ] 2bi node boa ; + +: new-child ( new-child node -- node' expansion/f ) + dup full? [ tuck level>> 1node ] [ node-add f ] if ; + +: pset-last ( val seq -- seq' ) + [ length 1- ] keep new-nth ; + +: node-set-last ( child node -- node' ) + clone [ pset-last ] change-children ; + +: (ppush-new-tail) ( tail node -- node' expansion/f ) + dup level>> 1 = [ + new-child + ] [ + tuck children>> peek (ppush-new-tail) + [ swap new-child ] [ swap node-set-last f ] ?if + ] if ; + +: do-expansion ( pvec root expansion/f -- pvec ) + [ 2node ] when* >>root ; + +: ppush-new-tail ( obj pvec -- pvec' ) + [ ] [ tail>> ] [ root>> ] tri + (ppush-new-tail) do-expansion + swap 0 1node >>tail ; + +M: persistent-vector ppush ( obj pvec -- pvec' ) + clone + dup tail>> full? + [ ppush-new-tail ] [ ppush-tail ] if + [ 1+ ] change-count ; + +: node-set-nth ( val i node -- node' ) + clone [ new-nth ] change-children ; + +: node-change-nth ( i node quot -- node' ) + [ clone ] dip '[ + clone [ , change-nth ] keep + ] change-children ; inline + +: (new-nth) ( val i node -- node' ) + dup level>> 0 = [ + [ node-mask ] dip node-set-nth + ] [ + [ dupd level>> node-shift node-mask ] keep + [ (new-nth) ] node-change-nth + ] if ; + +M: persistent-vector new-nth ( obj i pvec -- pvec' ) + 2dup count>> = [ nip ppush ] [ + clone + 2dup tail-offset >= [ + [ node-mask ] dip + [ node-set-nth ] change-tail + ] [ + [ (new-nth) ] change-root + ] if + ] if ; + +: (ppop-contraction) ( node -- node' tail' ) + clone [ unclip-last swap ] change-children swap ; + +: ppop-contraction ( node -- node' tail' ) + [ (ppop-contraction) ] [ level>> 1 = ] bi swap and ; + +: (ppop-new-tail) ( root -- root' tail' ) + dup level>> 1 > [ + dup children>> peek (ppop-new-tail) over children>> empty? + [ 2drop ppop-contraction ] [ [ swap node-set-last ] dip ] if + ] [ + ppop-contraction + ] if ; + +: ppop-tail ( pvec -- pvec' ) + [ clone [ ppop ] change-children ] change-tail ; + +: ppop-new-tail ( pvec -- pvec' ) + dup root>> (ppop-new-tail) + [ + dup [ level>> 1 > ] [ children>> length 1 = ] bi and + [ children>> first ] when + ] dip + [ >>root ] [ >>tail ] bi* ; + +PRIVATE> + +: pempty ( -- pvec ) + T{ persistent-vector f 0 T{ node f { } 1 } T{ node f { } 0 } } ; inline + +M: persistent-vector ppop ( pvec -- pvec' ) + dup count>> { + { 0 [ empty-error ] } + { 1 [ drop pempty ] } + [ + [ + clone + dup tail>> children>> length 1 > + [ ppop-tail ] [ ppop-new-tail ] if + ] dip 1- >>count + ] + } case ; + +M: persistent-vector like + drop pempty [ swap ppush ] reduce ; + +M: persistent-vector equal? + over persistent-vector? [ sequence= ] [ 2drop f ] if ; + +: >persistent-vector ( seq -- pvec ) pempty clone-like ; inline + +: PV{ \ } [ >persistent-vector ] parse-literal ; parsing + +M: persistent-vector pprint-delims drop \ PV{ \ } ; + +M: persistent-vector >pprint-sequence ; + +INSTANCE: persistent-vector immutable-sequence diff --git a/extra/persistent-vectors/summary.txt b/extra/persistent-vectors/summary.txt new file mode 100644 index 0000000000..19f3f66ca3 --- /dev/null +++ b/extra/persistent-vectors/summary.txt @@ -0,0 +1 @@ +Immutable vectors with O(log_32 n) random access and amortized O(1) push/pop diff --git a/extra/persistent-vectors/tags.txt b/extra/persistent-vectors/tags.txt new file mode 100644 index 0000000000..42d711b32b --- /dev/null +++ b/extra/persistent-vectors/tags.txt @@ -0,0 +1 @@ +collections From 32a95a79e42f74b3752d7e0dc50cb8f8e8da96bc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 6 Jun 2008 01:56:40 -0500 Subject: [PATCH 69/71] A bit of a cleanup --- extra/persistent-vectors/persistent-vectors.factor | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/extra/persistent-vectors/persistent-vectors.factor b/extra/persistent-vectors/persistent-vectors.factor index 6ed43ca0af..5e25be5dd3 100644 --- a/extra/persistent-vectors/persistent-vectors.factor +++ b/extra/persistent-vectors/persistent-vectors.factor @@ -1,7 +1,7 @@ ! Based on Clojure's PersistentVector by Rich Hickey. USING: math accessors kernel sequences.private sequences arrays -combinators parser prettyprint.backend fry debugger ; +combinators parser prettyprint.backend ; IN: persistent-vectors ERROR: empty-error pvec ; @@ -64,7 +64,6 @@ M: persistent-vector nth-unsafe swap 1array >>children ; : 2node ( first second -- node ) - 2dup [ level>> ] bi@ assert= [ 2array ] [ drop level>> 1+ ] 2bi node boa ; : new-child ( new-child node -- node' expansion/f ) @@ -102,9 +101,9 @@ M: persistent-vector ppush ( obj pvec -- pvec' ) clone [ new-nth ] change-children ; : node-change-nth ( i node quot -- node' ) - [ clone ] dip '[ - clone [ , change-nth ] keep - ] change-children ; inline + [ clone ] dip [ + [ clone ] dip [ change-nth ] 2keep drop + ] curry change-children ; inline : (new-nth) ( val i node -- node' ) dup level>> 0 = [ From 39262a128f55b217af9c1172a92ab55ff8c3a27e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 6 Jun 2008 03:40:29 -0500 Subject: [PATCH 70/71] Further cleanups --- .../persistent-vectors-docs.factor | 8 ++-- .../persistent-vectors.factor | 43 +++++++++---------- 2 files changed, 25 insertions(+), 26 deletions(-) diff --git a/extra/persistent-vectors/persistent-vectors-docs.factor b/extra/persistent-vectors/persistent-vectors-docs.factor index b0cb512d43..dc9222cedb 100644 --- a/extra/persistent-vectors/persistent-vectors-docs.factor +++ b/extra/persistent-vectors/persistent-vectors-docs.factor @@ -2,18 +2,18 @@ USING: help.markup help.syntax kernel math sequences ; IN: persistent-vectors HELP: new-nth -{ $values { "val" object } { "i" integer } { "seq" sequence } } +{ $values { "val" object } { "i" integer } { "seq" sequence } { "seq'" sequence } } { $contract "Persistent analogue of " { $link set-nth } ". Outputs a new sequence with the " { $snippet "i" } "th element replaced by " { $snippet "val" } "." } { $notes "This operation runs in " { $snippet "O(log_32 n)" } " time on " { $link persistent-vector } " instances and " { $snippet "O(n)" } " time on all other sequences." } ; HELP: ppush -{ $values { "val" object } { "i" integer } { "seq" sequence } } +{ $values { "val" object } { "seq" sequence } { "seq'" sequence } } { $contract "Persistent analogue of " { $link push } ". Outputs a new sequence with all elements of " { $snippet "seq" } " together with " { $snippet "val" } " added at the end." } { $notes "This operation runs in amortized " { $snippet "O(1)" } " time on " { $link persistent-vector } " instances and " { $snippet "O(n)" } " time on all other sequences." } ; HELP: ppop -{ $values { "val" object } { "i" integer } { "seq" sequence } } -{ $contract "Persistent analogue of " { $link pop } ". Outputs a new sequence with all elements of " { $snippet "seq" } " except for the final element." } +{ $values { "seq" sequence } { "seq'" sequence } } +{ $contract "Persistent analogue of " { $link pop* } ". Outputs a new sequence with all elements of " { $snippet "seq" } " except for the final element." } { $notes "This operation runs in amortized " { $snippet "O(1)" } " time on " { $link persistent-vector } " instances and " { $snippet "O(n)" } " time on all other sequences." } ; HELP: PV{ diff --git a/extra/persistent-vectors/persistent-vectors.factor b/extra/persistent-vectors/persistent-vectors.factor index 5e25be5dd3..f9f4b68933 100644 --- a/extra/persistent-vectors/persistent-vectors.factor +++ b/extra/persistent-vectors/persistent-vectors.factor @@ -6,7 +6,7 @@ IN: persistent-vectors ERROR: empty-error pvec ; -GENERIC: ppush ( obj seq -- seq' ) +GENERIC: ppush ( val seq -- seq' ) M: sequence ppush swap suffix ; @@ -14,7 +14,7 @@ GENERIC: ppop ( seq -- seq' ) M: sequence ppop 1 head* ; -GENERIC: new-nth ( obj i seq -- seq' ) +GENERIC: new-nth ( val i seq -- seq' ) M: sequence new-nth clone [ set-nth ] keep ; @@ -26,39 +26,38 @@ M: persistent-vector length count>> ; TUPLE: node children level ; -: node-mask HEX: 1f bitand ; inline - : node-size 32 ; inline -: tail-offset [ count>> ] [ tail>> children>> length ] bi - ; +: node-mask node-size mod ; inline : node-shift -5 * shift ; inline : node-nth ( i node -- obj ) - children>> [ node-mask ] dip nth ; inline + [ node-mask ] [ children>> ] bi* nth ; inline -: body-nth ( i node -- obj ) - dup level>> 0 > [ - [ drop ] [ [ level>> node-shift ] keep node-nth ] 2bi - body-nth - ] [ - node-nth - ] if ; inline +: body-nth ( i node -- i node' ) + dup level>> [ + dupd [ level>> node-shift ] keep node-nth + ] times ; inline + +: tail-offset ( pvec -- n ) + [ count>> ] [ tail>> children>> length ] bi - ; M: persistent-vector nth-unsafe 2dup tail-offset >= - [ tail>> node-nth ] [ root>> body-nth ] if ; + [ tail>> ] [ root>> body-nth ] if + node-nth ; -: node-add ( obj node -- node' ) +: node-add ( val node -- node' ) clone [ ppush ] change-children ; -: ppush-tail ( obj pvec -- pvec' ) +: ppush-tail ( val pvec -- pvec' ) [ node-add ] change-tail ; : full? ( node -- ? ) children>> length node-size = ; -: 1node ( obj level -- node ) +: 1node ( val level -- node ) node new swap >>level swap 1array >>children ; @@ -69,11 +68,11 @@ M: persistent-vector nth-unsafe : new-child ( new-child node -- node' expansion/f ) dup full? [ tuck level>> 1node ] [ node-add f ] if ; -: pset-last ( val seq -- seq' ) +: new-last ( val seq -- seq' ) [ length 1- ] keep new-nth ; : node-set-last ( child node -- node' ) - clone [ pset-last ] change-children ; + clone [ new-last ] change-children ; : (ppush-new-tail) ( tail node -- node' expansion/f ) dup level>> 1 = [ @@ -86,12 +85,12 @@ M: persistent-vector nth-unsafe : do-expansion ( pvec root expansion/f -- pvec ) [ 2node ] when* >>root ; -: ppush-new-tail ( obj pvec -- pvec' ) +: ppush-new-tail ( val pvec -- pvec' ) [ ] [ tail>> ] [ root>> ] tri (ppush-new-tail) do-expansion swap 0 1node >>tail ; -M: persistent-vector ppush ( obj pvec -- pvec' ) +M: persistent-vector ppush ( val pvec -- pvec' ) clone dup tail>> full? [ ppush-new-tail ] [ ppush-tail ] if @@ -173,7 +172,7 @@ M: persistent-vector like M: persistent-vector equal? over persistent-vector? [ sequence= ] [ 2drop f ] if ; -: >persistent-vector ( seq -- pvec ) pempty clone-like ; inline +: >persistent-vector ( seq -- pvec ) pempty like ; inline : PV{ \ } [ >persistent-vector ] parse-literal ; parsing From a9509a1f22416854be88afbe37368a9bf90ee7d9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 6 Jun 2008 03:40:35 -0500 Subject: [PATCH 71/71] Fix help lint failure in yahoo --- extra/yahoo/yahoo-docs.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/yahoo/yahoo-docs.factor b/extra/yahoo/yahoo-docs.factor index b5603103e1..1758d62029 100644 --- a/extra/yahoo/yahoo-docs.factor +++ b/extra/yahoo/yahoo-docs.factor @@ -2,5 +2,5 @@ USING: help.syntax help.markup ; IN: yahoo HELP: search-yahoo -{ $values { "search" "a string" } { "num" "a positive integer" } { "seq" "sequence of arrays of length 3" } } -{ $description "Uses Yahoo's REST API to search for the query specified in the search string, getting the number of answers specified. Returns a sequence of 3arrays, { title url summary }, each of which is a string." } ; +{ $values { "search" search } { "seq" "sequence of arrays of length 3" } } +{ $description "Uses Yahoo's REST API to search for the specified query, getting the number of answers specified. Returns a sequence of " { $link result } " instances." } ;
Summary:
Author:
Mode:
Body:
Body:
Captcha: