+
with-html-stream
- ] curry [ , \ show-final , ] [ ] make ;
+ ] curry ;
: html-outliner ( caption contents -- )
"+ " get-random-id dup >r
rot make-outliner-quot updating-anchor call
-
=id span> ;
+
=id "display: none; " =style span> ;
: outliner-tag ( style quot -- )
outline pick hash [ html-outliner ] [ call ] if* ;
@@ -179,6 +172,31 @@ M: html-stream with-nested-stream ( quot style stream -- )
] outliner-tag
] with-stream* ;
+: border-spacing-css,
+ "padding: " % first2 max 2 /i # "px; " % ;
+
+: table-style ( style -- str )
+ [
+ H{
+ { table-border [ border-css, ] }
+ { table-gap [ border-spacing-css, ] }
+ } hash-apply
+ ] "" make ;
+
+: table-attrs ( style -- )
+ table-style " border-collapse: collapse;" append =style ;
+
+M: html-stream with-stream-table ( grid quot style stream -- )
+ [
+
rot [
+ [
+ |
+ pick H{ } swap with-nesting
+ |
+ ] each
+ ] each 2drop
+ ] with-stream* ;
+
M: html-stream stream-terpri [
] with-stream* ;
: default-css ( -- )
@@ -186,7 +204,7 @@ M: html-stream stream-terpri [
] with-stream* ;
"A:link { text-decoration: none; color: black; }" print
"A:visited { text-decoration: none; color: black; }" print
"A:active { text-decoration: none; color: black; }" print
- "A:hover, A:hover { text-decoration: none; color: black; }" print
+ "A:hover, A:hover { text-decoration: underline; color: black; }" print
;
: xhtml-preamble
@@ -195,7 +213,7 @@ M: html-stream stream-terpri [
] with-stream* ;
: html-document ( title quot -- )
xhtml-preamble
- swap chars>entities dup
+ swap chars>entities
write
@@ -203,7 +221,6 @@ M: html-stream stream-terpri [
] with-stream* ;
include-prototype-js
-
write
call
;
diff --git a/contrib/httpd/http-common.factor b/contrib/httpd/http-common.factor
index 1d20e96795..c34117c978 100644
--- a/contrib/httpd/http-common.factor
+++ b/contrib/httpd/http-common.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2003, 2005 Slava Pestov
IN: http
-USING: errors hashtables io kernel lists math namespaces parser
+USING: errors hashtables io kernel math namespaces parser
sequences strings ;
: header-line ( line -- )
diff --git a/contrib/httpd/httpd.factor b/contrib/httpd/httpd.factor
index ebf3a5de80..003ec82d91 100644
--- a/contrib/httpd/httpd.factor
+++ b/contrib/httpd/httpd.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2003, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: httpd
-USING: errors hashtables kernel lists namespaces io strings
+USING: errors hashtables kernel namespaces io strings
threads http sequences ;
: (url>path) ( uri -- path )
diff --git a/contrib/httpd/inspect-responder.factor b/contrib/httpd/inspect-responder.factor
index 10d05e58b8..5b821b376e 100644
--- a/contrib/httpd/inspect-responder.factor
+++ b/contrib/httpd/inspect-responder.factor
@@ -1,16 +1,15 @@
! Copyright (C) 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: inspect-responder
-USING: cont-responder generic hashtables help html inspector
-kernel lists namespaces sequences ;
+USING: callback-responder generic hashtables help html httpd
+inspector kernel namespaces sequences ;
! Mini object inspector
: http-inspect ( obj -- )
- "Inspecting " over summary append
- [ describe ] simple-html-document ;
+ dup summary [ describe ] simple-html-document ;
M: general-t browser-link-href
- [ [ http-inspect ] show-final ] curry quot-url ;
+ [ http-inspect ] curry t register-html-callback ;
: inspect-responder ( url -- )
- [ global http-inspect ] show-final ;
+ serving-html global http-inspect ;
diff --git a/contrib/httpd/load.factor b/contrib/httpd/load.factor
index 7af1b24c54..e5d91a251f 100644
--- a/contrib/httpd/load.factor
+++ b/contrib/httpd/load.factor
@@ -1,28 +1,30 @@
-IN: scratchpad
-USING: words kernel parser sequences io compiler ;
+USING: io ;
-{
- "mime"
- "xml"
- "http-common"
- "html-tags"
- "responder"
- "httpd"
- "cont-responder"
- "prototype-js"
- "html"
- "file-responder"
- "help-responder"
- "inspect-responder"
- "browser-responder"
- "default-responders"
- "http-client"
+REQUIRES: embedded ;
- "test/html"
- "test/http-client"
- "test/httpd"
- "test/url-encoding"
-} [ "/contrib/httpd/" swap ".factor" append3 run-resource ] each
+PROVIDE: httpd {
+ "mime.factor"
+ "xml.factor"
+ "http-common.factor"
+ "html-tags.factor"
+ "responder.factor"
+ "httpd.factor"
+ "callback-responder.factor"
+ "cont-responder.factor"
+ "prototype-js.factor"
+ "html.factor"
+ "file-responder.factor"
+ "help-responder.factor"
+ "inspect-responder.factor"
+ "browser-responder.factor"
+ "default-responders.factor"
+ "http-client.factor"
+} {
+ "test/html.factor"
+ "test/http-client.factor"
+ "test/httpd.factor"
+ "test/url-encoding.factor"
+} ;
"To start the HTTP server, issue the following command in the listener:" print
" USE: httpd" print
diff --git a/contrib/httpd/mime.factor b/contrib/httpd/mime.factor
index cab8531f06..0f04e8bdd3 100644
--- a/contrib/httpd/mime.factor
+++ b/contrib/httpd/mime.factor
@@ -28,7 +28,7 @@ H{
{ "gz" "application/octet-stream" }
{ "pdf" "application/pdf" }
-
+
{ "factor" "text/plain" }
- { "factsp" "application/x-factor-server-page" }
+ { "fhtml" "application/x-factor-server-page" }
} "mime-types" global set-hash
diff --git a/contrib/httpd/prototype-js.factor b/contrib/httpd/prototype-js.factor
index 3cad30ec1b..77185973e5 100644
--- a/contrib/httpd/prototype-js.factor
+++ b/contrib/httpd/prototype-js.factor
@@ -5,23 +5,35 @@
! For information and license details for protoype
! see http://prototype.conio.net
IN: prototype-js
-USING: io httpd cont-responder html kernel lists namespaces strings ;
+USING: callback-responder html httpd io kernel namespaces
+strings ;
: include-prototype-js ( -- )
#! Write out the HTML script tag to include the prototype
#! javascript library.
- ;
: updating-javascript ( id quot -- string )
#! Return the javascript code to perform the updating
#! ajax call.
- quot-url swap
+ t register-html-callback swap
[ "new Ajax.Updater(\"" % % "\",\"" % % "\", { method: \"get\" });" % ] "" make ;
+: toggle-javascript ( string id -- string )
+ [
+ "if(Element.visible(\"" % dup % "\"))" %
+ "Element.hide(\"" % dup % "\");" %
+ "else {" %
+ swap %
+ " Element.show(\"" % % "\"); }" %
+ ] "" make ;
+
: updating-anchor ( text id quot -- )
#! Write the HTML for an anchor that when clicked will
#! call the given quotation on the server. The output generated
#! from that quotation will replace the DOM element on the page with
#! the given id. The 'text' is the anchor text.
-
write ;
+ over >r updating-javascript r> toggle-javascript
+
write ;
diff --git a/contrib/httpd/responder.factor b/contrib/httpd/responder.factor
index 111998468c..259ed0852c 100644
--- a/contrib/httpd/responder.factor
+++ b/contrib/httpd/responder.factor
@@ -1,8 +1,8 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: httpd
-USING: arrays hashtables http kernel lists math namespaces
-parser sequences io strings ;
+USING: arrays hashtables html http io kernel math namespaces
+parser sequences strings ;
! Variables
SYMBOL: vhosts
@@ -15,7 +15,7 @@ SYMBOL: responders
"HTTP/1.0 " write print print-header ;
: error-body ( error -- body )
- "
" swap "
" append3 print ;
+
write
;
: error-head ( error -- )
dup log-error
@@ -91,10 +91,18 @@ SYMBOL: responders
! - header -- a hashtable of headers from the user's client
! - response -- a hashtable of the POST request response
+: query-param ( key -- value ) "query" get hash ;
+
: add-responder ( responder -- )
#! Add a responder object to the list.
"responder" over hash responders get set-hash ;
+: add-simple-responder ( name quot -- )
+ [
+ [ drop ] swap append dup "get" set "post" set
+ "responder" set
+ ] make-hash add-responder ;
+
: make-responder ( quot -- responder )
[
( url -- )
diff --git a/contrib/httpd/test/html.factor b/contrib/httpd/test/html.factor
index a1fc1aec63..aca595ce67 100644
--- a/contrib/httpd/test/html.factor
+++ b/contrib/httpd/test/html.factor
@@ -15,7 +15,7 @@ USING: html http io kernel namespaces styles test xml ;
[
[
"/home/slava/doc/" "doc-root" set
- "/home/slava/doc/foo/bar" file-link-href
+ "/home/slava/doc/foo/bar"
browser-link-href
] with-scope
] unit-test
diff --git a/contrib/httpd/test/httpd.factor b/contrib/httpd/test/httpd.factor
index 105c294da7..72c47bfc97 100644
--- a/contrib/httpd/test/httpd.factor
+++ b/contrib/httpd/test/httpd.factor
@@ -6,7 +6,6 @@ USE: namespaces
USE: io
USE: test
USE: strings
-USE: lists
[ "HTTP/1.0 200 OK\nContent-Length: 12\nContent-Type: text/html\n\n" ]
[
diff --git a/contrib/httpd/xml.factor b/contrib/httpd/xml.factor
index efa768a95b..23d6305f0a 100644
--- a/contrib/httpd/xml.factor
+++ b/contrib/httpd/xml.factor
@@ -1,75 +1,13 @@
-USING: arrays errors generic hashtables io kernel lists math
+USING: arrays errors generic hashtables io kernel math
namespaces parser prettyprint sequences strings vectors words ;
IN: xml
-! * Simple SAX-ish parser
-
-! -- Basic utility words
-
SYMBOL: code #! Source code
SYMBOL: spot #! Current index of string
SYMBOL: version
SYMBOL: line
SYMBOL: column
-: set-code ( string -- ) ! for debugging
- code set [ spot line column ] [ 0 swap set ] each ;
-
-: more? ( -- ? )
- #! Return t if spot is not at the end of code
- code get length spot get = not ;
-
-: char ( -- char/f )
- more? [ spot get code get nth ] [ f ] if ;
-
-: incr-spot ( -- )
- #! Increment spot.
- spot [ 1 + ] change
- char "\n\r" member? [
- 0 column set
- line
- ] [
- column
- ] if [ 1 + ] change ;
-
-: skip-until ( quot -- | quot: char -- ? )
- more? [
- char swap [ call ] keep swap [ drop ] [
- incr-spot skip-until
- ] if
- ] [ drop ] if ; inline
-
-: take-until ( quot -- string | quot: char -- ? )
- #! Take the substring of a string starting at spot
- #! from code until the quotation given is true and
- #! advance spot to after the substring.
- spot get >r skip-until r>
- spot get code get subseq ; inline
-
-: pass-blank ( -- )
- #! Advance code past any whitespace, including newlines
- [ blank? not ] skip-until ;
-
-: string-matches? ( string -- ? )
- spot get dup pick length + code get subseq = ;
-
-DEFER:
-: (take-until-string) ( string -- n )
- more? [
- dup string-matches? [
- drop spot get
- ] [
- incr-spot (take-until-string)
- ] if
- ] [ "Missing closing token" throw ] if ;
-
-: take-until-string ( string -- string )
- [ >r spot get r> (take-until-string) code get subseq ] keep
- length spot [ + ] change ;
-
-: in-range-seq? ( number { [[ min max ]] ... } -- ? )
- [ uncons between? not ] all-with? not ;
-
! -- Error reporting
TUPLE: xml-error line column ;
@@ -111,6 +49,58 @@ M: xml-string-error error.
dup xml-error.
xml-string-error-string print ;
+! -- Basic utility words
+
+: set-code ( string -- ) ! for debugging
+ code set [ spot line column ] [ 0 swap set ] each ;
+
+: more? ( -- ? )
+ #! Return t if spot is not at the end of code
+ code get length spot get = not ;
+
+: char ( -- char/f )
+ more? [ spot get code get nth ] [ f ] if ;
+
+: incr-spot ( -- )
+ #! Increment spot.
+ spot inc
+ char "\n\r" member? [ 0 column set line ] [ column ] if
+ inc ;
+
+: skip-until ( quot -- | quot: char -- ? )
+ more? [
+ char swap [ call ] keep swap [ drop ] [
+ incr-spot skip-until
+ ] if
+ ] [ drop ] if ; inline
+
+: take-until ( quot -- string | quot: char -- ? )
+ #! Take the substring of a string starting at spot
+ #! from code until the quotation given is true and
+ #! advance spot to after the substring.
+ spot get >r skip-until r>
+ spot get code get subseq ; inline
+
+: pass-blank ( -- )
+ #! Advance code past any whitespace, including newlines
+ [ blank? not ] skip-until ;
+
+: string-matches? ( string -- ? )
+ spot get dup pick length + code get subseq = ;
+
+: (take-until-string) ( string -- n )
+ more? [
+ dup string-matches? [
+ drop spot get
+ ] [
+ incr-spot (take-until-string)
+ ] if
+ ] [ "Missing closing token" throw ] if ;
+
+: take-until-string ( string -- string )
+ [ >r spot get r> (take-until-string) code get subseq ] keep
+ length spot [ + ] change ;
+
! -- Parsing strings
: expect ( ch -- )
@@ -119,18 +109,20 @@ M: xml-string-error error.
] if incr-spot ;
: expect-string ( string -- )
- >r spot get r> t over [ char incr-spot = and ] each [ 2drop ] [
+ >r spot get r> t over [ char incr-spot = and ] each [
+ 2drop
+ ] [
swap spot get code get subseq throw
] if ;
: entities
#! We have both directions here as a shortcut.
H{
- { "lt" CHAR: < }
- { "gt" CHAR: > }
- { "amp" CHAR: & }
- { "apos" CHAR: ' }
- { "quot" CHAR: " }
+ { "lt" CHAR: < }
+ { "gt" CHAR: > }
+ { "amp" CHAR: & }
+ { "apos" CHAR: ' }
+ { "quot" CHAR: " }
{ CHAR: < "<" }
{ CHAR: > ">" }
{ CHAR: & "&" }
@@ -139,43 +131,59 @@ M: xml-string-error error.
} ;
: parse-entity ( -- ch )
- incr-spot [ CHAR: ; = ] take-until incr-spot
- dup first CHAR: # = [
- 1 swap tail "x" ?head 16 10 ? base>
+ incr-spot [ CHAR: ; = ] take-until "#" ?head [
+ "x" ?head 16 10 ? base>
] [
- dup entities hash [ nip ] [ throw ] if*
+ dup entities hash [ ] [ throw ] ?if
] if ;
-: (parse-text) ( vector -- vector )
- [ CHAR: & = ] take-until over push
- char CHAR: & = [
- parse-entity ch>string over push (parse-text)
- ] when ;
+: parsed-ch ( buf ch -- buf ) over push incr-spot ;
-: parse-text ( string -- string )
- [
- code set 0 spot set
- 100 (parse-text) concat
- ] with-scope ;
+: (parse-text) ( buf -- buf )
+ {
+ { [ more? not ] [ ] }
+ { [ char CHAR: < = ] [ ] }
+ { [ char CHAR: & = ] [ parse-entity parsed-ch (parse-text) ] }
+ { [ t ] [ char parsed-ch (parse-text) ] }
+ } cond ;
-: get-text ( -- string )
- [ CHAR: < = ] take-until parse-text ;
+: parse-text ( -- string )
+ SBUF" " clone (parse-text) >string ;
! -- Parsing tags
+: in-range-seq? ( number { { min max } ... } -- ? )
+ [ first2 between? ] contains-with? ;
+
: name-start-char? ( ch -- ? )
- dup ":_" member? swap {
- [[ CHAR: A CHAR: Z ]] [[ CHAR: a CHAR: z ]] [[ HEX: C0 HEX: D6 ]]
- [[ HEX: D8 HEX: F6 ]] [[ HEX: F8 HEX: 2FF ]] [[ HEX: 370 HEX: 37D ]]
- [[ HEX: 37F HEX: 1FFF ]] [[ HEX: 200C HEX: 200D ]] [[ HEX: 2070 HEX: 218F ]]
- [[ HEX: 2C00 HEX: 2FEF ]] [[ HEX: 3001 HEX: D7FF ]] [[ HEX: F900 HEX: FDCF ]]
- [[ HEX: FDF0 HEX: FFFD ]] [[ HEX: 10000 HEX: EFFFF ]]
- } in-range-seq? or ;
+ {
+ { CHAR: : CHAR: : }
+ { CHAR: _ CHAR: _ }
+ { CHAR: A CHAR: Z }
+ { CHAR: a CHAR: z }
+ { HEX: C0 HEX: D6 }
+ { HEX: D8 HEX: F6 }
+ { HEX: F8 HEX: 2FF }
+ { HEX: 370 HEX: 37D }
+ { HEX: 37F HEX: 1FFF }
+ { HEX: 200C HEX: 200D }
+ { HEX: 2070 HEX: 218F }
+ { HEX: 2C00 HEX: 2FEF }
+ { HEX: 3001 HEX: D7FF }
+ { HEX: F900 HEX: FDCF }
+ { HEX: FDF0 HEX: FFFD }
+ { HEX: 10000 HEX: EFFFF }
+ } in-range-seq? ;
: name-char? ( ch -- ? )
- dup name-start-char? over "-." member? or over HEX: B7 = or swap
- { [[ CHAR: 0 CHAR: 9 ]] [[ HEX: 300 HEX: 36F ]] [[ HEX: 203F HEX: 2040 ]] }
- in-range-seq? or ;
+ dup name-start-char? swap {
+ { CHAR: - CHAR: - }
+ { CHAR: . CHAR: . }
+ { CHAR: 0 CHAR: 9 }
+ { HEX: b7 HEX: b7 }
+ { HEX: 300 HEX: 36F }
+ { HEX: 203F HEX: 2040 }
+ } in-range-seq? or ;
: parse-name ( -- name )
char dup name-start-char? [
@@ -184,56 +192,70 @@ M: xml-string-error error.
"Malformed name" throw
] if ;
-: parse-quot ( ch -- str )
- incr-spot [ dupd = ] take-until parse-text nip incr-spot ;
-
-: parse-prop-value ( -- str )
- char dup "'\"" member? [
- parse-quot
- ] [
- "Attribute lacks quote" throw
- ] if ;
-
-: parse-prop ( -- { name value } )
- parse-name pass-blank CHAR: = expect pass-blank
- parse-prop-value 2array pass-blank ;
-
TUPLE: opener name props ;
TUPLE: closer name ;
TUPLE: contained name props ;
TUPLE: comment text ;
+TUPLE: directive text ;
: start-tag ( -- string ? )
#! Outputs the name and whether this is a closing tag
char CHAR: / = dup [ incr-spot ] when
parse-name swap ;
-: (middle-tag) ( list -- list )
- pass-blank char name-char? [ parse-prop swons (middle-tag) ] when ;
+: (parse-quot) ( ch buf -- buf )
+ {
+ { [ more? not ] [ nip ] }
+ { [ char pick = ] [ incr-spot nip ] }
+ { [ char CHAR: & = ] [ parse-entity parsed-ch (parse-quot) ] }
+ { [ t ] [ char parsed-ch (parse-quot) ] }
+ } cond ;
-: middle-tag ( -- hash )
- f (middle-tag) alist>hash ;
+: parse-quot ( ch -- str )
+ SBUF" " clone (parse-quot) >string ;
-: end-tag ( string hash -- tag )
- pass-blank char CHAR: / = [
- incr-spot
+: parse-prop-value ( -- str )
+ char dup "'\"" member? [
+ incr-spot parse-quot
] [
-
+ "Attribute lacks quote" throw
] if ;
+: parse-prop ( -- name value )
+ parse-name pass-blank CHAR: = expect pass-blank
+ parse-prop-value 2array ;
+
+: (middle-tag) ( seq -- seq )
+ pass-blank char name-char?
+ [ parse-prop over push (middle-tag) ] when ;
+
+: middle-tag ( -- hash )
+ V{ } clone (middle-tag) alist>hash pass-blank ;
+
+: end-tag ( string hash -- tag )
+ pass-blank char CHAR: / =
+ [ incr-spot ] [ ] if ;
+
: skip-comment ( -- comment )
- "--" expect-string "--" take-until-string CHAR: > expect ;
+ "--" expect-string
+ "--" take-until-string
+
+ CHAR: > expect ;
: cdata ( -- string )
"[CDATA[" expect-string "]]>" take-until-string ;
-: cdata/comment ( -- object )
- incr-spot char CHAR: - = [ skip-comment ] [ cdata ] if ;
+: directive ( -- object )
+ {
+ { [ "--" string-matches? ] [ skip-comment ] }
+ { [ "[CDATA[" string-matches? ] [ cdata ] }
+ { [ t ] [ ">" take-until-string ] }
+ } cond ;
: make-tag ( -- tag/f )
CHAR: < expect
char CHAR: ! = [
- cdata/comment
+ incr-spot directive
] [
start-tag [
@@ -251,30 +273,11 @@ TUPLE: comment text ;
"version" swap hash [ version set ] when*
] when ;
-: dip-ns ( quot -- )
- n> slip >n ; inline
-
-: (xml-each) ( quot -- )
- get-text swap [ dip-ns ] keep
- more? [
- make-tag [ swap [ dip-ns ] keep ] when* (xml-each)
- ] [ drop ] if ; inline
-
-: xml-each ( string quot -- | quot: node -- )
- #! Quotation is called with each node: an opener, closer, contained,
- #! comment, or string
- #! Somewhat like SAX but vastly simplified.
- [
- swap code set
- [ spot line column ] [ 0 swap set ] each
- "1.0" version set
- get-version (xml-each)
- ] with-scope ; inline
-
! * Data tree
TUPLE: tag name props children ;
+! A stack of { tag children } pairs
SYMBOL: xml-stack
TUPLE: mismatched open close ;
@@ -285,47 +288,62 @@ M: mismatched error.
TUPLE: unclosed tags ;
C: unclosed ( -- unclosed )
- 1 xml-stack get tail-slice [ car opener-name ] map
+ 1 xml-stack get tail-slice [ first opener-name ] map
swap [ set-unclosed-tags ] keep ;
M: unclosed error.
"Unclosed tags" print
"Tags: " print
unclosed-tags [ " <" write write ">" print ] each ;
-: push-datum ( object -- )
- xml-stack get peek cdr push ;
+: add-child ( object -- )
+ xml-stack get peek second push ;
+
+: push-xml-stack ( object -- )
+ V{ } clone 2array xml-stack get push ;
GENERIC: process ( object -- )
-M: string process push-datum ;
-M: comment process push-datum ;
+M: f process drop ;
+
+M: string process add-child ;
+M: comment process add-child ;
+M: directive process add-child ;
M: contained process
- [ contained-name ] keep contained-props 0 push-datum ;
+ [ contained-name ] keep contained-props
+ V{ } clone add-child ;
M: opener process
- V{ } clone cons
- xml-stack get push ;
+ push-xml-stack ;
M: closer process
- closer-name xml-stack get pop uncons
- >r [
+ closer-name xml-stack get pop first2 >r [
opener-name [
2dup = [ 2drop ] [ swap throw ] if
] keep
- ] keep opener-props r> push-datum ;
+ ] keep opener-props r> add-child ;
-: initialize-xml-stack ( -- )
- f V{ } clone cons unit >vector xml-stack set ;
+: init-xml-stack ( -- )
+ V{ } clone xml-stack set f push-xml-stack ;
-: xml ( string -- tag )
+: init-xml ( string -- )
+ code set
+ [ spot line column ] [ 0 swap set ] each
+ "1.0" version set
+ init-xml-stack ;
+
+: (string>xml) ( -- )
+ parse-text process
+ more? [ make-tag process (string>xml) ] when ; inline
+
+: string>xml ( string -- tag )
#! Produces a tree of XML nodes
[
- initialize-xml-stack
- [ process ] xml-each
+ init-xml
+ get-version (string>xml)
xml-stack get
dup length 1 = [ throw ] unless
- first cdr second
+ first second
] with-scope ;
! * Printer
@@ -356,16 +374,14 @@ M: tag (xml>string)
CHAR: < ,
dup tag-name %
dup tag-props print-props
- dup tag-children [ "" = not ] subset empty? [
- drop "/>" %
- ] [
- print-open/close
- ] if ;
+ dup tag-children [ empty? not ] contains?
+ [ print-open/close ] [ drop "/>" % ] if ;
M: comment (xml>string)
- "" % ;
+ "" % ;
+
+M: object (xml>string)
+ [ (xml>string) ] each ;
: xml-preamble
"" ;
@@ -374,13 +390,13 @@ M: comment (xml>string)
[ xml-preamble % (xml>string) ] "" make ;
: xml-reprint ( string -- string )
- xml xml>string ;
+ string>xml xml>string ;
! * Easy XML generation for more literal things
! should this be rewritten?
: text ( string -- )
- chars>entities push-datum ;
+ chars>entities add-child ;
: tag ( string attr-quot contents-quot -- )
>r swap >r make-hash r> swap r>
@@ -391,15 +407,15 @@ M: comment (xml>string)
: text-tag ( content name attr-quot -- ) [ text ] tag ; inline
: comment ( string -- )
- push-datum ;
+ add-child ;
: make-xml ( quot -- vector )
#! Produces a tree of XML from a quotation to generate it
[
- initialize-xml-stack
+ init-xml-stack
call
xml-stack get
- first cdr first
+ first second first
] with-scope ; inline
! * System for words specialized on tag names
@@ -416,14 +432,3 @@ M: process-missing error.
>r dup tag-name r> hash* [ 2nip call ] [
drop throw
] if ;
-
-: PROCESS:
- CREATE
- dup H{ } clone "xtable" set-word-prop
- dup literalize [ run-process ] cons define-compound ; parsing
-
-: TAG:
- scan scan-word [
- swap "xtable" word-prop
- rot "/" split [ >r 2dup r> swap set-hash ] each 2drop
- ] f ; parsing
diff --git a/library/bootstrap/win32-io.factor b/contrib/lazy-lists/examples.factor
similarity index 63%
rename from library/bootstrap/win32-io.factor
rename to contrib/lazy-lists/examples.factor
index ccceb72eb7..c94e3c4ccf 100644
--- a/library/bootstrap/win32-io.factor
+++ b/contrib/lazy-lists/examples.factor
@@ -1,8 +1,6 @@
-! :folding=indent:collapseFolds=1:
-
-! $Id$
+! Rewritten by Matthew Willis, July 2006
!
-! Copyright (C) 2003, 2004 Mackenzie Straight.
+! Copyright (C) 2004 Chris Double.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
@@ -25,25 +23,26 @@
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-IN: io
-USE: compiler
-USE: namespaces
-USE: kernel
-USE: win32-io-internals
-USE: win32-stream
-USE: win32-api
+USING: lazy-lists math kernel sequences test ;
+IN: lazy-examples
-: ;
-: ;
-: ;
+: naturals 0 lfrom ;
+: positves 1 lfrom ;
+: evens 0 [ 2 + ] lfrom-by ;
+: odds 1 lfrom [ 2 mod 1 = ] lsubset ;
+: powers-of-2 1 [ 2 * ] lfrom-by ;
+: ones 1 [ ] lfrom-by ;
+: squares naturals [ dup * ] lmap ;
+: first-five-squares 5 squares ltake list>array ;
-IN: io-internals
+: divisible-by? ( a b -- bool )
+ #! Return true if a is divisible by b
+ mod 0 = ;
-: io-multiplex ( timeout -- )
- #! FIXME: needs to work given a timeout
- dup -1 = [ drop INFINITE ] when cancel-timedout wait-for-io
- swap [ continue-with ] [ drop ] if* ;
+: filter-multiples ( n list - list )
+ #! Given a lazy list of numbers, filter multiples of n
+ swap [ divisible-by? not ] curry lsubset ;
-: init-io ( -- )
- win32-init-stdio ;
+: primes 2 lfrom [ filter-multiples ] lapply ;
+: first-ten-primes 10 primes ltake list>array ;
\ No newline at end of file
diff --git a/contrib/lazy-lists/lists.factor b/contrib/lazy-lists/lists.factor
new file mode 100644
index 0000000000..40e988a3b4
--- /dev/null
+++ b/contrib/lazy-lists/lists.factor
@@ -0,0 +1,207 @@
+! Updated by Matthew Willis, July 2006
+!
+! Copyright (C) 2004 Chris Double.
+!
+! Redistribution and use in source and binary forms, with or without
+! modification, are permitted provided that the following conditions are met:
+!
+! 1. Redistributions of source code must retain the above copyright notice,
+! this list of conditions and the following disclaimer.
+!
+! 2. Redistributions in binary form must reproduce the above copyright notice,
+! this list of conditions and the following disclaimer in the documentation
+! and/or other materials provided with the distribution.
+!
+! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+USING: kernel sequences math vectors arrays namespaces ;
+IN: lazy-lists
+
+TUPLE: promise quot forced? value ;
+
+C: promise ( quot -- promise ) [ set-promise-quot ] keep ;
+
+: force ( promise -- value )
+ #! Force the given promise leaving the value of calling the
+ #! promises quotation on the stack. Re-forcing the promise
+ #! will return the same value and not recall the quotation.
+ dup promise-forced? [
+ dup promise-quot call over set-promise-value
+ t over set-promise-forced?
+ ] unless
+ promise-value ;
+
+TUPLE: cons car cdr ;
+
+: nil ( -- list )
+ #! The nil lazy list.
+ T{ promise f [ { } ] t { } } ;
+
+: nil? ( list -- bool )
+ #! Is the given lazy cons the nil value
+ force { } = ;
+
+: car ( list -- car )
+ #! Return the value of the head of the lazy list.
+ force cons-car ;
+
+: cdr ( list -- cdr )
+ #! Return the rest of the lazy list.
+ #! This is itself a lazy list.
+ force cons-cdr ;
+
+: cons ( car cdr -- list )
+ #! Given a car and cdr, both lazy values, return a lazy cons.
+ [ swap , , \ , ] [ ] make ;
+
+: lunit ( obj -- list )
+ #! Given a value produce a lazy list containing that value.
+ nil cons ;
+
+: lnth ( n list -- value )
+ #! Return the nth item in a lazy list
+ swap [ cdr ] times car ;
+
+: uncons ( cons -- car cdr )
+ #! Return the car and cdr of the lazy list
+ force dup cons-car swap cons-cdr ;
+
+: force-promise ( list-quot -- list )
+ #! Promises to force list-quot, which should be
+ #! a quot that produces a list.
+ #! This allows caching of the resultant list value.
+ [ call \ force , ] [ ] make ; inline
+
+DEFER: lmap
+: (lmap) ( list quot -- list )
+ over nil? [ drop ]
+ [
+ swap 2dup
+ cdr swap lmap >r
+ car swap call r>
+ cons
+ ] if ;
+
+: lmap ( list quot -- list )
+ #! Return a lazy list containing the collected result of calling
+ #! quot on the original lazy list.
+ [ swap , , \ (lmap) , ] force-promise ;
+
+DEFER: ltake
+: (ltake) ( n list -- list )
+ over 0 = [ 2drop nil ]
+ [ dup nil? [ nip ]
+ [
+ swap ( list n -- list )
+ 1 - >r uncons r> swap ltake
+ cons
+ ] if
+ ] if ;
+
+: ltake ( n list -- list )
+ #! Return a lazy list containing the first n items from
+ #! the original lazy list.
+ [ swap , , \ (ltake) , ] force-promise ;
+
+DEFER: lsubset
+: (lsubset) ( list pred -- list )
+ >r dup nil? [ r> drop ]
+ [
+ uncons swap dup r> dup >r call
+ [ swap r> lsubset cons ]
+ [ drop r> (lsubset) ] if
+ ] if ;
+
+: lsubset ( list pred -- list )
+ #! Return a lazy list containing the elements in llist
+ #! satisfying pred
+ [ swap , , \ (lsubset) , ] force-promise ;
+
+: (list>backwards-vector) ( list -- vector )
+ dup nil? [ drop V{ } clone ]
+ [ uncons (list>backwards-vector) swap over push ] if ;
+
+: list>vector ( list -- vector )
+ #! Convert a lazy list to a vector. This will cause
+ #! an infinite loop if the lazy list is an infinite list.
+ (list>backwards-vector) reverse ;
+
+: list>array ( list -- array )
+ list>vector >array ;
+
+DEFER: backwards-vector>list
+: (backwards-vector>list) ( vector -- list )
+ dup empty? [ drop nil ]
+ [ dup pop swap backwards-vector>list cons ] if ;
+
+: backwards-vector>list ( vector -- list )
+ [ , \ (backwards-vector>list) , ] force-promise ;
+
+: array>list ( array -- list )
+ #! Convert a list to a lazy list.
+ reverse >vector backwards-vector>list ;
+
+DEFER: lappend*
+: (lappend*) ( lists -- list )
+ dup nil? [
+ uncons >r dup nil? [ drop r> (lappend*) ]
+ [ uncons r> cons lappend* cons ] if
+ ] unless ;
+
+: lappend* ( llists -- list )
+ #! Given a lazy list of lazy lists, concatenate them
+ #! together in a lazy fashion. The actual appending is
+ #! done lazily on iteration rather than immediately
+ #! so it works very fast no matter how large the lists.
+ [ , \ (lappend*) , ] force-promise ;
+
+: lappend ( list1 list2 -- llist )
+ #! Concatenate two lazy lists such that they appear to be one big
+ #! lazy list.
+ lunit cons lappend* ;
+
+: leach ( list quot -- )
+ #! Call the quotation on each item in the lazy list.
+ #! Warning: If the list is infinite then this will
+ #! never return.
+ swap dup nil? [ 2drop ] [
+ uncons swap pick call swap leach
+ ] if ;
+
+DEFER: lapply
+: (lapply) ( list quot -- list )
+ over nil? [ drop ] [
+ swap dup car >r uncons pick call swap lapply
+ r> swap cons
+ ] if ;
+
+: lapply ( list quot -- list )
+ #! Returns a lazy list which is
+ #! (cons (car list)
+ #! (lapply (quot (car list) (cdr list)) quot))
+ #! This allows for complicated list functions
+ [ swap , , \ (lapply) , ] force-promise ;
+
+DEFER: lfrom-by
+: (lfrom-by) ( n quot -- list )
+ 2dup call swap lfrom-by cons ;
+
+: lfrom-by ( n quot -- list )
+ #! Return a lazy list of values starting from n, with
+ #! each successive value being the result of applying quot to
+ #! n.
+ [ swap , , \ (lfrom-by) , ] force-promise ;
+
+: lfrom ( n -- list )
+ #! Return a lazy list of increasing numbers starting
+ #! from the initial value 'n'.
+ [ 1 + ] lfrom-by ;
\ No newline at end of file
diff --git a/contrib/lazy-lists/load.factor b/contrib/lazy-lists/load.factor
new file mode 100644
index 0000000000..aa21a80788
--- /dev/null
+++ b/contrib/lazy-lists/load.factor
@@ -0,0 +1,7 @@
+PROVIDE: lazy-lists {
+ "lists.factor"
+ "examples.factor"
+} {
+ "test/lists.factor"
+ "test/examples.factor"
+} ;
\ No newline at end of file
diff --git a/contrib/parser-combinators/lazy.html b/contrib/lazy-lists/old-doc.html
similarity index 100%
rename from contrib/parser-combinators/lazy.html
rename to contrib/lazy-lists/old-doc.html
diff --git a/contrib/lazy-lists/test/examples.factor b/contrib/lazy-lists/test/examples.factor
new file mode 100644
index 0000000000..e60305a71a
--- /dev/null
+++ b/contrib/lazy-lists/test/examples.factor
@@ -0,0 +1,6 @@
+USING: lazy-examples lazy-lists test ;
+IN: temporary
+
+[ { 1 3 5 7 } ] [ 4 odds ltake list>array ] unit-test
+[ { 0 1 4 9 16 } ] [ first-five-squares ] unit-test
+[ { 2 3 5 7 11 13 17 19 23 29 } ] [ first-ten-primes ] unit-test
diff --git a/library/windows/win32-errors.factor b/contrib/lazy-lists/test/lists.factor
similarity index 51%
rename from library/windows/win32-errors.factor
rename to contrib/lazy-lists/test/lists.factor
index a1bbe15e50..4975f1d82d 100644
--- a/library/windows/win32-errors.factor
+++ b/contrib/lazy-lists/test/lists.factor
@@ -1,8 +1,4 @@
-! :folding=indent:collapseFolds=1:
-
-! $Id$
-!
-! Copyright (C) 2004 Mackenzie Straight.
+! Copyright (C) 2006 Matthew Willis.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
@@ -25,46 +21,40 @@
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-IN: win32-api
-USE: errors
-USE: kernel
-USE: io-internals
-USE: lists
-USE: math
-USE: parser
-USE: alien
-USE: words
-USE: sequences
-
-: CONSTANT: CREATE
- [ [ [ swons ] each ] cons define-compound POSTPONE: parsing ]
- [ ] ; parsing
-
-CONSTANT: ERROR_SUCCESS 0 ;
-CONSTANT: ERROR_HANDLE_EOF 38 ;
-CONSTANT: ERROR_IO_PENDING 997 ;
-CONSTANT: WAIT_TIMEOUT 258 ;
-
-: FORMAT_MESSAGE_ALLOCATE_BUFFER HEX: 00000100 ;
-: FORMAT_MESSAGE_IGNORE_INSERTS HEX: 00000200 ;
-: FORMAT_MESSAGE_FROM_STRING HEX: 00000400 ;
-: FORMAT_MESSAGE_FROM_HMODULE HEX: 00000800 ;
-: FORMAT_MESSAGE_FROM_SYSTEM HEX: 00001000 ;
-: FORMAT_MESSAGE_ARGUMENT_ARRAY HEX: 00002000 ;
-: FORMAT_MESSAGE_MAX_WIDTH_MASK HEX: 000000FF ;
-
-: MAKELANGID ( primary sub -- lang )
- 10 shift bitor ;
-
-: LANG_NEUTRAL 0 ;
-: SUBLANG_DEFAULT 1 ;
-
-: GetLastError ( -- int )
- "int" "kernel32" "GetLastError" [ ] alien-invoke ;
-
-: win32-error-message ( id -- string )
- "char*" f "error_message" [ "int" ] alien-invoke ;
-
-: win32-throw-error ( -- )
- GetLastError win32-error-message throw ;
+USING: lazy-lists test kernel math io ;
+IN: temporary
+[ t ] [ nil nil? ] unit-test
+[ 5 ] [ 5 lunit car ] unit-test
+[ f ] [ nil nil cons nil? ] unit-test
+[ 5 t ] [ 5 lunit uncons nil? ] unit-test
+[ 6 ] [
+ 5 6 lunit cons
+ 1 swap lnth
+ ] unit-test
+[ 12 13 t ] [
+ 5 6 lunit cons
+ [ 7 + ] lmap uncons uncons nil?
+ ] unit-test
+[ 5 6 t ] [
+ 5 6 7 lunit cons cons 2 swap ltake
+ uncons uncons nil?
+ ] unit-test
+[ 6 7 t ] [ 5 6 7 lunit cons cons [ 5 > ] lsubset
+ uncons uncons nil? ] unit-test
+[ 7 t ] [ 5 6 7 lunit cons cons [ 6 > ] lsubset
+ uncons nil? ] unit-test
+[ 1 3 5 t ] [ { 1 3 5 } array>list
+ uncons uncons uncons nil? ] unit-test
+[ { 1 3 5 } ] [ { 1 3 5 } array>list list>array ] unit-test
+[ { 1 2 3 4 5 6 7 8 9 } ] [
+ { 1 2 3 } array>list
+ { 4 5 6 } array>list
+ { 7 8 9 } array>list
+ lunit cons cons lappend* list>array ] unit-test
+[ { 1 2 3 4 5 6 } ]
+[ { 1 2 3 } array>list { 4 5 6 } array>list
+ lappend list>array ] unit-test
+[ ] [ { 1 2 3 } array>list [ 3 + number>string print ] leach ] unit-test
+[ { 1 2 3 4 } ]
+ [ 0 lfrom [ 5 < ] lsubset [ 0 > ] lsubset 4 swap ltake list>array ] unit-test
diff --git a/contrib/load.factor b/contrib/load.factor
deleted file mode 100644
index 14f4b1b4e4..0000000000
--- a/contrib/load.factor
+++ /dev/null
@@ -1,26 +0,0 @@
-! Load all contrib libs, compile them, and save a new image.
-IN: scratchpad
-USING: alien compiler kernel memory parser sequences words ;
-
-{
- "coroutines"
- "dlists"
- "splay-trees"
-} [ "/contrib/" swap ".factor" append3 run-resource clear ] each
-
-{ "cairo"
- "math"
- "concurrency"
- "crypto"
- "aim"
- "httpd"
- "units"
- "sqlite"
- "win32"
- "x11"
- ! "factory" has a C component, ick.
- "postgresql"
- "parser-combinators"
- "cont-responder"
- "space-invaders"
-} [ "/contrib/" swap "/load.factor" append3 run-resource clear ] each
diff --git a/contrib/math/combinatorics.factor b/contrib/math/combinatorics.factor
index f1c7a93657..72b17da3a0 100644
--- a/contrib/math/combinatorics.factor
+++ b/contrib/math/combinatorics.factor
@@ -17,19 +17,24 @@ USING: kernel sequences errors namespaces math ;
#! calculate n! given n, k, k!
(k..n] product * ;
-
: nCk ( n k -- nCk )
#! uses the results from min(k!,(n-k)!) to compute max(k!,(n-k)!)
#! use max(k!,(n-k)!) to compute n!
- 2dup < [ "n >= k only" throw ] when
- [ - ] 2keep rot 2dup < [ swap ] when
- [ factorial ] keep over
- >r rot [ factorial-part ] keep rot pick >r factorial-part r> r> * / ;
+ 2dup < [
+ 2drop 0
+ ] [
+ [ - ] 2keep rot 2dup < [ swap ] when
+ [ factorial ] keep over
+ >r rot [ factorial-part ] keep rot pick >r factorial-part r> r> * /
+ ] if ;
: nPk ( n k -- nPk )
#! uses the results from (n-k)! to compute n!
- 2dup < [ "n >= k only" throw ] when
- 2dup - nip [ factorial ] keep rot pick >r factorial-part r> / ;
+ 2dup < [
+ 2drop 0
+ ] [
+ 2dup - nip [ factorial ] keep rot pick >r factorial-part r> /
+ ] if ;
: binomial ( n k -- nCk )
#! same as nCk
diff --git a/contrib/math/infix.factor b/contrib/math/infix.factor
deleted file mode 100644
index f0c8e1df70..0000000000
--- a/contrib/math/infix.factor
+++ /dev/null
@@ -1,365 +0,0 @@
-IN: infix
-USING: arrays errors generic hashtables io kernel kernel-internals lists math math-contrib namespaces parser parser-combinators prettyprint sequences strings vectors words ;
-
-: 2list ( x y -- [ x y ] ) f cons cons ;
-
-! Tokenizer
-
-TUPLE: tok char ;
-
-TUPLE: brackets seq ender ;
-
-SYMBOL: apostrophe
-
-SYMBOL: code #! Source code
-SYMBOL: spot #! Current index of string
-
-: take-until ( quot -- parsed-stuff | quot: char -- ? )
- #! Take the substring of a string starting at spot
- #! from code until the quotation given is true and
- #! advance spot to after the substring.
- >r spot get code get 2dup r>
- skip [ swap subseq ] keep
- spot set ;
-
-: parse-blank ( -- )
- #! Advance code past any whitespace, including newlines
- spot get code get [ blank? not ] skip spot set ;
-
-: not-done? ( -- ? )
- #! Return t if spot is not at the end of code
- code get length spot get = not ;
-
-: incr-spot ( -- )
- #! Increment spot.
- spot [ 1 + ] change ;
-
-: parse-var ( -- variable-name )
- #! Take a series of letters from code, advancing
- #! spot and returning the letters.
- [ letter? not ] take-until ;
-
-: parse-num ( -- number )
- #! Take a number from code, advancing spot and
- #! returning the number.
- [ "0123456789." member? not ] take-until string>number ;
-
-: get-token ( -- char )
- spot get code get nth ;
-
-DEFER: token
-
-: next-token ( list -- list )
- #! Take one token from code and return it
- parse-blank not-done? [
- get-token token
- ] when ;
-
-: token
- {
- { [ dup letter? ] [ drop parse-var swons ] }
- { [ dup "0123456789." member? ] [ drop parse-num swons ] }
- { [ dup ";!@#$%^&*?/|\\=+_-~" member? ] [ swons incr-spot ] }
- { [ dup "([{" member? ] [ drop f incr-spot ] }
- { [ dup ")]}" member? ] [ swons incr-spot ] }
- { [ dup CHAR: ' = ] [ drop apostrophe swons incr-spot ] }
- { [ t ] [ "Bad character " swap ch>string append throw ] }
- } cond next-token ;
-
-: tokenize ( string -- tokens )
- #! Tokenize a string, returning a list of tokens
- [
- code set 0 spot set
- f next-token reverse
- ] with-scope ;
-
-
-! Parser
-
-TUPLE: apply func args ;
- #! Function application
-C: apply
- >r [ ] subset r>
- [ set-apply-args ] keep
- [ set-apply-func ] keep ;
-
-UNION: value number string ;
-
-: semicolon ( -- semicolon )
- #! The semicolon token
- T{ tok f CHAR: ; } ;
-
-: unswons uncons swap ;
-
-: nest-apply ( [ ast ] -- apply )
- unswons unit swap [
- swap unit
- ] each car ;
-
-GENERIC: parse-token ( ast tokens token -- ast tokens )
- #! Take one or more tokens
-
-DEFER: parse-tokens
-
-: semicolon-split ( list -- [ ast ] )
- reverse semicolon unit split [ parse-tokens ] map ;
-
-M: value parse-token
- swapd swons swap ;
-
-M: brackets parse-token
- swapd dup brackets-seq swap brackets-ender {
- { [ dup CHAR: ] = ] [ drop semicolon-split >r unswons r> swons ] }
- { [ dup CHAR: } = ] [ drop semicolon-split >vector swons ] }
- { [ CHAR: ) = ] [ reverse parse-tokens swons ] }
- } cond swap ;
-
-M: object tok-char drop -1 ; ! Hack!
-
-GENERIC: tok>string ( token/string -- string )
-M: tok tok>string
- tok-char ch>string ;
-M: string tok>string ;
-
-: binary-op ( ast tokens token -- ast )
- >r >r unswons r> parse-tokens 2list r>
- tok>string swap swons ;
-
-: unary-op ( ast tokens token -- ast )
- tok>string -rot nip
- parse-tokens unit unit ;
-
-: null-op ( ast tokens token -- ast )
- nip tok-char ch>string swons ;
-
-M: tok parse-token
- over [
- pick [
- binary-op
- ] [
- unary-op
- ] if
- ] [
- null-op
- ] if f ;
-
-( ast tokens token -- ast tokens )
-
-M: symbol parse-token ! apostrophe
- drop unswons >r parse-tokens >r unswons r> 2list r>
- unit parse-tokens swap swons f ;
-
-: (parse-tokens) ( ast tokens -- ast )
- dup [
- unswons parse-token (parse-tokens)
- ] [
- drop
- ] if ;
-
-: parse-tokens ( tokens -- ast )
- #! Convert a list of tokens into an AST
- f swap (parse-tokens) nest-apply ;
-
-: parse-full ( string -- ast )
- #! Convert a string into an AST
- tokenize parse-tokens ;
-
-
-! Compiler
-
-GENERIC: compile-ast ( vars ast -- quot )
-
-M: string compile-ast ! variables
- swap index dup -1 = [
- "Variable not found" throw
- ] [
- [ swap array-nth ] cons
- ] if ;
-
-: replace-with ( data -- [ drop data ] )
- \ drop swap 2list ;
-
-UNION: comp-literal number general-list ;
-
-M: comp-literal compile-ast ! literal numbers
- replace-with nip ;
-
-: accumulator ( vars { asts } quot -- quot )
- -rot [
- [
- \ dup ,
- compile-ast %
- dup %
- ] each-with
- ] [ ] make nip ;
-
-M: vector compile-ast ! literal vectors
- dup [ number? ] all? [
- replace-with nip
- ] [
- [ , ] accumulator [ { } make nip ] cons
- ] if ;
-
-: infix-relation
- #! Wraps operators like = and > so that if they're given
- #! f as either argument, they return f, and they return f if
- #! the operation yields f, but if it yields t, it returns the
- #! left argument. This way, these types of operations can be
- #! composed.
- >r 2dup and not [
- r> 3drop f
- ] [
- dupd r> call [
- drop f
- ] unless
- ] if ;
-
-: functions
- #! Regular functions
- #! Gives quotation applicable to stack
- H{
- [ [[ "+" 2 ]] + ]
- [ [[ "-" 2 ]] - ]
- [ [[ ">" 2 ]] [ > ] infix-relation ]
- [ [[ "<" 2 ]] [ < ] infix-relation ]
- [ [[ "=" 2 ]] [ = ] infix-relation ]
- [ [[ "-" 1 ]] neg ]
- [ [[ "~" 1 ]] not ]
- [ [[ "&" 2 ]] and ]
- [ [[ "|" 2 ]] or ]
- [ [[ "&" 1 ]] t [ and ] reduce ]
- [ [[ "|" 1 ]] f [ or ] reduce ]
- [ [[ "*" 2 ]] * ]
- [ [[ "ln" 1 ]] log ]
- [ [[ "plusmin" 2 ]] [ + ] 2keep - ]
- [ [[ "@" 2 ]] swap nth ]
- [ [[ "sqrt" 1 ]] sqrt ]
- [ [[ "/" 2 ]] / ]
- [ [[ "^" 2 ]] ^ ]
- [ [[ "#" 1 ]] length ]
- [ [[ "eq" 2 ]] eq? ]
- [ [[ "*" 1 ]] first ]
- [ [[ "+" 1 ]] flip ]
- [ [[ "\\" 1 ]] ]
- [ [[ "sin" 1 ]] sin ]
- [ [[ "cos" 1 ]] cos ]
- [ [[ "tan" 1 ]] tan ]
- [ [[ "max" 2 ]] max ]
- [ [[ "min" 2 ]] min ]
- [ [[ "," 2 ]] append ]
- [ [[ "," 1 ]] concat ]
- [ [[ "sn" 3 ]] -rot set-nth ]
- [ [[ "prod" 1 ]] product ]
- [ [[ "vec" 1 ]] >vector ]
- } ;
-
-: drc ( list -- list )
- #! all of list except last element (backwards cdr)
- dup cdr [
- uncons drc cons
- ] [
- drop f
- ] if ;
-
-: map-with-left ( seq object quot -- seq )
- [ swapd call ] cons swapd map-with ; inline
-
-: high-functions
- #! Higher-order functions
- #! Gives quotation applicable to quotation and rest of stack
- H{
- [ [[ "!" 2 ]] 2map ]
- [ [[ "!" 1 ]] map ]
- [ [[ ">" 2 ]] map-with ]
- [ [[ "<" 2 ]] map-with-left ]
- [ [[ "^" 1 ]] all? ]
- [ [[ "~" 1 ]] call not ]
- [ [[ "~" 2 ]] call not ]
- [ [[ "/" 2 ]] swapd reduce ]
- [ [[ "\\" 2 ]] swapd accumulate ]
- } ;
-
-: get-hash ( key table -- value )
- #! like hash but throws exception if f
- dupd hash [ nip ] [
- [ "Key not found " write . ] string-out throw
- ] if* ;
-
-: >apply< ( apply -- func args )
- dup apply-func swap apply-args ;
-
-: make-apply ( arity apply/string -- quot )
- dup string? [
- swons functions get-hash
- ] [
- >apply< car >r over r> make-apply
- -rot swons high-functions get-hash cons
- ] if ;
-
-: get-function ( apply -- quot )
- >apply< length swap make-apply ;
-
-M: apply compile-ast ! function application
- [ apply-args [ swap ] accumulator [ drop ] append ] keep
- get-function append ;
-
-: push-list ( list item -- list )
- unit append ;
-
-: parse-comp ( args string -- quot )
- #! Compile a string into a quotation w/o prologue
- parse-full compile-ast ;
-
-: prologue ( args -- quot )
- #! Build the prolog for a function
- [
- length dup , \ ,
- [ 1 - ] keep [
- 2dup - [ swap set-array-nth ] cons , \ keep ,
- ] repeat drop
- ] [ ] make ;
-
-: ast>quot ( args ast -- quot )
- over prologue -rot compile-ast append ;
-
-: define-math ( seq -- )
- " " join
- dup parse-full apply-args uncons car swap
- >apply< >r create-in r>
- [ "math-args" set-word-prop ] 2keep
- >r tuck >r >r swap "code" set-word-prop r> r> r>
- rot ast>quot define-compound ;
-
-: MATH:
- #! MATH: sq[x]=x*x ;
- "in-definition" on
- string-mode on
- [
- string-mode off define-math
- ] f ; parsing
-
-: TEST-MATH:
- #! Executes and prints the result of a math
- #! expression at parsetime
- string-mode on [
- " " join string-mode off parse-full
- f swap ast>quot call .
- ] f ; parsing
-
-! PREDICATE: compound infix-word "code" word-prop ;
-! M: infix-word definer
-! drop POSTPONE: MATH: ;
-! M: infix-word class.
-! "code" word-prop write " ;" print ;
-!
-! Redefine compound to not include infix words so see works
-! IN: words
-! USING: kernel words parse-k ;
-!
-! PREDICATE: word compound
-! dup word-primitive 1 = swap infix-word? not and ;
-
-
-
-MATH: quadratic[a;b;c] =
- plusmin[(-b)/2*a;(sqrt(b^2)-4*a*c)/2*a] ;
diff --git a/contrib/math/load.factor b/contrib/math/load.factor
index f068373e47..4ab7c2ace4 100644
--- a/contrib/math/load.factor
+++ b/contrib/math/load.factor
@@ -1,13 +1,10 @@
-IN: scratchpad
-USING: kernel parser sequences words compiler ;
-
-{
- "utils"
- "combinatorics"
- "analysis"
- "polynomials"
- "quaternions"
- "matrices"
- "statistics"
- "numerical-integration"
-} [ "/contrib/math/" swap ".factor" append3 run-resource ] each
+PROVIDE: math {
+ "utils.factor"
+ "combinatorics.factor"
+ "analysis.factor"
+ "polynomials.factor"
+ "quaternions.factor"
+ "matrices.factor"
+ "statistics.factor"
+ "numerical-integration.factor"
+} ;
diff --git a/contrib/math/numerical-integration.factor b/contrib/math/numerical-integration.factor
index 68df4a26e4..b56cb21b33 100644
--- a/contrib/math/numerical-integration.factor
+++ b/contrib/math/numerical-integration.factor
@@ -1,7 +1,6 @@
IN: math-contrib
-USING: kernel sequences errors namespaces math lists vectors errors prettyprint ;
-USING: io inspector ;
+USING: kernel sequences errors namespaces math vectors errors prettyprint io inspector ;
: setup-range ( from to -- frange )
step-size get swap ;
diff --git a/contrib/math/utils.factor b/contrib/math/utils.factor
index 25105740e9..a31535fb19 100644
--- a/contrib/math/utils.factor
+++ b/contrib/math/utils.factor
@@ -13,6 +13,13 @@ USING: errors kernel sequences math sequences-internals namespaces arrays ;
gcd 1 = [ "Non-trivial divisor found" throw ] unless ;
foldable
+: each-bit ( n quot -- | quot: 0/1 -- )
+ over zero? pick -1 number= or [
+ 2drop
+ ] [
+ 2dup >r >r >r 1 bitand r> call r> -1 shift r> each-bit
+ ] if ; inline
+
: (^mod) ( n z w -- z^w )
1 swap [
1 number= [ dupd * pick mod ] when >r sq over mod r>
diff --git a/contrib/parser-combinators/lazy-examples.factor b/contrib/parser-combinators/lazy-examples.factor
deleted file mode 100644
index 84459d5d0b..0000000000
--- a/contrib/parser-combinators/lazy-examples.factor
+++ /dev/null
@@ -1,66 +0,0 @@
-! Copyright (C) 2004 Chris Double.
-!
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice,
-! this list of conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-! this list of conditions and the following disclaimer in the documentation
-! and/or other materials provided with the distribution.
-!
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-IN: lazy-examples
-USE: lazy
-USE: math
-USE: lists
-USE: parser-combinators
-USE: kernel
-USE: sequences
-USE: namespaces
-
-: lfrom ( n -- llist )
- #! Return a lazy list of increasing numbers starting
- #! from the initial value 'n'.
- dup unit delay swap
- [ 1 + lfrom ] cons delay lcons ;
-
-: lfrom-by ( n quot -- llist )
- #! Return a lazy list of values starting from n, with
- #! each successive value being the result of applying quot to
- #! n.
- swap dup unit delay -rot
- [ , dup , \ call , , \ lfrom-by , ] [ ] make delay lcons ;
-
-: lnaturals 0 lfrom ;
-: lpositves 1 lfrom ;
-: levens 0 [ 2 + ] lfrom-by ;
-: lodds 1 lfrom [ 2 mod 1 = ] lsubset ;
-: lpowers-of-2 1 [ 2 * ] lfrom-by ;
-: lones 1 [ ] lfrom-by ;
-: lsquares lnaturals [ dup * ] lmap ;
-: first-five-squares 5 lsquares ltake ;
-
-: divisible-by? ( a b -- bool )
- #! Return true if a is divisible by b
- mod 0 = ;
-
-: sieve ( llist - llist )
- #! Given a lazy list of numbers, use the sieve of eratosthenes
- #! algorithm to return a lazy list of primes.
- luncons over [ divisible-by? not ]
- cons lsubset [ sieve ] cons delay >r unit delay r> lcons ;
-
-: lprimes 2 lfrom sieve ;
-
-: first-ten-primes 10 lprimes ltake llist>list ;
diff --git a/contrib/parser-combinators/lazy.factor b/contrib/parser-combinators/lazy.factor
deleted file mode 100644
index 69b85b28bf..0000000000
--- a/contrib/parser-combinators/lazy.factor
+++ /dev/null
@@ -1,265 +0,0 @@
-! Copyright (C) 2004 Chris Double.
-!
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice,
-! this list of conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-! this list of conditions and the following disclaimer in the documentation
-! and/or other materials provided with the distribution.
-!
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-IN: lazy
-USE: kernel
-USE: sequences
-USE: namespaces
-USE: lists
-USE: math
-
-TUPLE: promise quot forced? value ;
-
-: delay ( quot -- )
- #! Given a quotation, create a promise which may later be forced.
- #! When forced the quotation will execute returning the value. Future
- #! forces of the promise will return that value and not re-execute
- #! the quotation.
- f f ;
-
-: (force) ( -- value )
- #! Force the given promise leaving the value of calling the
- #! promises quotation on the stack. Re-forcing the promise
- #! will return the same value and not recall the quotation.
- dup promise-forced? [
- dup promise-quot call over set-promise-value
- t over set-promise-forced?
- ] unless
- promise-value ;
-
-: force ( -- value )
- (force) dup promise? [
- force
- ] when ;
-
-TUPLE: lcons car cdr ;
-
-SYMBOL: lazy-nil
-DEFER: lnil
-[ [ ] ] delay lazy-nil set
-
-: lnil ( -- lcons )
- #! Return the nil lazy list.
- lazy-nil get ;
-
-: lnil? ( lcons -- bool )
- #! Is the given lazy cons the nil value
- force not ;
-
-: lcar ( lcons -- car )
- #! Return the value of the head of the lazy list.
- dup lnil? [
- force lcons-car (force)
- ] unless ;
-
-: lcdr ( lcons -- cdr )
- #! Return the value of the rest of the lazy list.
- #! This is itself a lazy list.
- dup lnil? [
- force lcons-cdr (force)
- ] unless ;
-
-: lcons ( lcar lcdr -- promise )
- #! Given a car and cdr, both lazy values, return a lazy cons.
- swap [ , , \ , ] [ ] make delay ;
-
-: lunit ( lvalue -- llist )
- #! Given a lazy value (a quotation that when called produces
- #! the value) produce a lazy list containing that value.
- [ lnil ] delay lcons ;
-
-: lnth ( n llist -- value )
- #! Return the nth item in a lazy list
- swap [ lcdr ] times lcar ;
-
-: luncons ( lcons -- car cdr )
- #! Return the car and cdr of the lazy list
- dup lcar swap lcdr ;
-
-: lmap ( llist quot -- llist )
- #! Return a lazy list containing the collected result of calling
- #! quot on the original lazy list.
- over lnil? [
- drop
- ] [
- swap 2dup
- [ , \ lcdr , , \ lmap , ] [ ] make delay >r
- [ , \ lcar , , \ call , ] [ ] make delay r>
- lcons
- ] if ;
-
-: ltake ( n llist -- llist )
- #! Return a lazy list containing the first n items from
- #! the original lazy list.
- over 0 = [
- 2drop lnil
- ] [
- dup lnil? [
- nip
- ] [
- swap dupd ( llist llist n -- )
- [ [ 1 - ] cons , \ call , , \ lcdr , \ ltake , ] [ ] make delay >r
- [ , \ lcar , ] [ ] make delay r>
- lcons
- ] if
- ] if ;
-
-DEFER: lsubset
-TUPLE: lsubset-state llist pred ;
-
-: (lsubset-cdr) ( state -- llist )
- #! Given a predicate and a lazy list, do the cdr
- #! portion of lsubset.
- dup lsubset-state-llist lcdr swap lsubset-state-pred lsubset ;
-
-: (lsubset-car) ( state -- value )
- #! Given a predicate and a lazy list, do the car
- #! portion of lsubset.
- dup lsubset-state-llist lcar over
- lsubset-state-pred dupd call [ ( state lcar -- )
- nip
- ] [ ( state lcar -- )
- drop dup lsubset-state-llist lcdr over set-lsubset-state-llist
- (lsubset-car)
- ] if ;
-
-: (lsubset-set-first-car) ( state -- bool )
- #! Set the state to the first valid car. If none found
- #! return false.
- dup lsubset-state-llist lcar over
- lsubset-state-pred dupd call [ ( state lcar -- )
- 2drop t
- ] [ ( state lcar -- )
- drop dup lsubset-state-llist lcdr dup lnil? [
- 2drop f
- ] [
- over set-lsubset-state-llist
- (lsubset-set-first-car)
- ] if
- ] if ;
-
-: lsubset ( llist pred -- llist )
- #! Return a lazy list containing only the items from the original
- #! lazy list for which the predicate returns a value other than f.
- over lnil? [
- drop
- ] [
- dup
- (lsubset-set-first-car) [
- dup
- [ (lsubset-cdr) ] cons delay >r
- [ (lsubset-car) ] cons delay r> lcons
- ] [
- drop lnil
- ] if
- ] if ;
-
-DEFER: lappend*
-DEFER: (lappend*)
-TUPLE: lappend*-state current rest ;
-
-USE: io
-
-: (lappend*-cdr) ( state -- llist )
- #! Given the state object, do the cdr portion of the
- #! lazy append.
- dup lappend*-state-current dup lnil? [ ( state current -- )
- nip
- ] [ ( state current -- )
- lcdr ( state cdr -- )
- dup lnil? [ ( state cdr -- )
- drop dup lappend*-state-rest dup lnil? [ ( state rest )
- nip
- ] [
- nip
- luncons ( state rest-car rest-cdr -- )
- (lappend*)
- ] if
- ] [ ( state cdr -- )
- swap lappend*-state-rest (lappend*)
- ] if
- ] if ;
-
-: (lappend*-car) ( state -- value )
- #! Given the state object, do the car portion of the
- #! lazy append.
- dup lappend*-state-current dup lnil? [ ( state current -- )
- nip
- ] [ ( state current -- )
- lcar nip
- ] if ;
-
-: (lappend*) ( state -- llist )
- #! Do the main work of the lazy list appending using a
- #! state object.
- dup
- [ (lappend*-cdr) ] cons delay >r
- [ (lappend*-car) ] cons delay r> lcons ;
-
-: lappend* ( llists -- llist )
- #! Given a lazy list of lazy lists, return a lazy list that
- #! works through all of the sub-lists in sequence.
- [ lnil? not ] lsubset
- dup lnil? [
- luncons