diff --git a/extra/inverse/inverse.factor b/extra/inverse/inverse.factor index 4d85318c1b..583ae610c0 100644 --- a/extra/inverse/inverse.factor +++ b/extra/inverse/inverse.factor @@ -1,18 +1,9 @@ USING: kernel words inspector slots quotations sequences assocs math arrays inference effects shuffle continuations debugger tuples namespaces vectors bit-arrays byte-arrays strings sbufs -math.functions macros ; +math.functions macros combinators.private combinators ; IN: inverse -: (repeat) ( from to quot -- ) - pick pick >= [ - 3drop - ] [ - [ swap >r call 1+ r> ] keep (repeat) - ] if ; inline - -: repeat ( n quot -- ) 0 -rot (repeat) ; inline - TUPLE: fail ; : fail ( -- * ) \ fail construct-empty throw ; M: fail summary drop "Unification failed" ; @@ -27,17 +18,12 @@ M: fail summary drop "Unification failed" ; : define-inverse ( word quot -- ) "inverse" set-word-prop ; : define-math-inverse ( word quot1 quot2 -- ) - 2array "math-inverse" set-word-prop ; + pick 1quotation 3array "math-inverse" set-word-prop ; : define-pop-inverse ( word n quot -- ) >r dupd "pop-length" set-word-prop r> "pop-inverse" set-word-prop ; -DEFER: [undo] - -: make-inverse ( word -- quot ) - word-def [undo] ; - TUPLE: no-inverse word ; : no-inverse ( word -- * ) \ no-inverse construct-empty throw ; M: no-inverse summary @@ -54,10 +40,7 @@ M: no-inverse summary effect-in length 0 = and ; : assure-constant ( constant -- quot ) - dup word? [ - dup constant-word? - [ "Badly formed math inverse" throw ] unless - ] when 1quotation ; + dup word? [ "Badly formed math inverse" throw ] when 1quotation ; : swap-inverse ( math-inverse revquot -- revquot* quot ) next assure-constant rot second [ swap ] swap 3compose ; @@ -68,25 +51,52 @@ M: no-inverse summary : ?word-prop ( word/object name -- value/f ) over word? [ word-prop ] [ 2drop f ] if ; -GENERIC: inverse ( revquot word -- revquot* quot ) - -M: word inverse - dup "inverse" word-prop [ ] - [ dup primitive? [ no-inverse ] [ make-inverse ] if ] ?if ; - : undo-literal ( object -- quot ) [ =/fail ] curry ; +PREDICATE: word normal-inverse "inverse" word-prop ; +PREDICATE: word math-inverse "math-inverse" word-prop ; +PREDICATE: word pop-inverse "pop-length" word-prop ; +UNION: explicit-inverse normal-inverse math-inverse pop-inverse ; + +: inline-word ( word -- ) + { + { [ dup word? not over symbol? or ] [ , ] } + { [ dup explicit-inverse? ] [ , ] } + { [ dup compound? over { if dispatch } member? not and ] + [ word-def [ inline-word ] each ] } + { [ drop t ] [ "Quotation is not invertible" throw ] } + } cond ; + +: math-exp? ( n n word -- ? ) + { + - * / ^ } member? -rot [ number? ] 2apply and and ; + +: (fold-constants) ( quot -- ) + dup length 3 < [ % ] [ + dup first3 3dup math-exp? + [ execute , 3 ] [ 2drop , 1 ] if + tail-slice (fold-constants) + ] if ; + +: fold-constants ( quot -- folded ) + [ (fold-constants) ] [ ] make ; + +: do-inlining ( quot -- inlined-quot ) + [ [ inline-word ] each ] [ ] make fold-constants ; + +GENERIC: inverse ( revquot word -- revquot* quot ) + M: object inverse undo-literal ; M: symbol inverse undo-literal ; -PREDICATE: word math-inverse "math-inverse" word-prop ; +M: normal-inverse inverse + "inverse" word-prop ; + M: math-inverse inverse "math-inverse" word-prop swap next dup \ swap = [ drop swap-inverse ] [ pull-inverse ] if ; -PREDICATE: word pop-inverse "pop-length" word-prop ; M: pop-inverse inverse [ "pop-length" word-prop cut-slice swap ] keep "pop-inverse" word-prop compose call ; @@ -96,11 +106,11 @@ M: pop-inverse inverse [ unclip-slice inverse % (undo) ] if ; : [undo] ( quot -- undo ) - reverse [ (undo) ] [ ] make ; + do-inlining reverse [ (undo) ] [ ] make ; MACRO: undo ( quot -- ) [undo] ; -! Inversions of selected words +! Inverse of selected words \ swap [ swap ] define-inverse \ dup [ [ =/fail ] keep ] define-inverse diff --git a/extra/rss/rss-tests.factor b/extra/rss/rss-tests.factor index 643c2ecf51..18aa8440b9 100644 --- a/extra/rss/rss-tests.factor +++ b/extra/rss/rss-tests.factor @@ -1,5 +1,9 @@ -USING: rss io.files tools.test ; -IN: temporary +USING: rss io kernel io.files tools.test ; + +: load-news-file ( filename -- feed ) + #! Load an news syndication file and process it, returning + #! it as an feed tuple. + read-feed ; [ T{ feed @@ -34,4 +38,3 @@ IN: temporary } } } ] [ "extra/rss/atom.xml" resource-path load-news-file ] unit-test -[ " & & hi" ] [ " & & hi" &>& ] unit-test diff --git a/extra/rss/rss.factor b/extra/rss/rss.factor index 1f7105bf57..8a9be3f9f6 100644 --- a/extra/rss/rss.factor +++ b/extra/rss/rss.factor @@ -62,23 +62,17 @@ C: entry children>string ] map ; -: feed ( xml -- feed ) +: xml>feed ( xml -- feed ) dup name-tag { { "RDF" [ rss1.0 ] } { "rss" [ rss2.0 ] } { "feed" [ atom1.0 ] } } case ; -: read-feed ( string -- feed ) - ! &>& ! this will be uncommented when parser-combinators are fixed - [ string>xml ] with-html-entities feed ; +: read-feed ( stream -- feed ) + [ read-xml ] with-html-entities xml>feed ; -: load-news-file ( filename -- feed ) - #! Load an news syndication file and process it, returning - #! it as an feed tuple. - [ contents read-feed ] keep stream-close ; - -: news-get ( url -- feed ) +: download-feed ( url -- feed ) #! Retrieve an news syndication file, return as a feed tuple. http-get rot 200 = [ nip read-feed @@ -90,7 +84,7 @@ C: entry : simple-tag, ( content name -- ) [ , ] tag, ; -: (generate-atom) ( entry -- ) +: entry, ( entry -- ) "entry" [ dup entry-title "title" simple-tag, "link" over entry-link "href" associate contained*, @@ -98,9 +92,12 @@ C: entry entry-description "content" simple-tag, ] tag, ; -: generate-atom ( feed -- xml ) - "feed" [ +: feed>xml ( feed -- xml ) + "feed" { { "xmlns" "http://www.w3.org/2005/Atom" } } [ dup feed-title "title" simple-tag, "link" over feed-link "href" associate contained*, - feed-entries [ (generate-atom) ] each - ] make-xml ; + feed-entries [ entry, ] each + ] make-xml* ; + +: write-feed ( feed -- xml ) + feed>xml write-xml ; diff --git a/extra/units/si/si.factor b/extra/units/si/si.factor index c07ffb8423..9029d6bd35 100644 --- a/extra/units/si/si.factor +++ b/extra/units/si/si.factor @@ -38,8 +38,11 @@ IN: units.si : cd/m^2 { cd } { m m } ; : kg/kg { kg } { kg } ; -: radians ( n -- radian ) { m } { m } ; -: sr ( n -- steradian ) { m m } { m m } ; +! Radians are really m/m, and steradians are m^2/m^2 +! but they need to be in reduced form here. +: radians ( n -- radian ) scalar ; +: sr ( n -- steradian ) scalar ; + : Hz ( n -- hertz ) { } { s } ; : N ( n -- newton ) { kg m } { s s } ; : Pa ( n -- pascal ) { kg } { m s s } ;