diff --git a/extra/prolog/authors.txt b/extra/prolog/authors.txt new file mode 100644 index 0000000000..194cb22416 --- /dev/null +++ b/extra/prolog/authors.txt @@ -0,0 +1 @@ +Gavin Harrison diff --git a/extra/prolog/prolog.factor b/extra/prolog/prolog.factor new file mode 100644 index 0000000000..0a6a513b97 --- /dev/null +++ b/extra/prolog/prolog.factor @@ -0,0 +1,84 @@ +! Copyright (C) 2007 Gavin Harrison +! See http://factorcode.org/license.txt for BSD license. + +USING: kernel sequences arrays vectors namespaces math strings + combinators continuations quotations io assocs ; + +IN: prolog + +SYMBOL: pldb +SYMBOL: plchoice + +: init-pl ( -- ) V{ } clone pldb set V{ } clone plchoice set ; + +: reset-choice ( -- ) V{ } clone plchoice set ; +: remove-choice ( -- ) plchoice get pop drop ; +: add-choice ( continuation -- ) + dup continuation? [ plchoice get push ] [ drop ] if ; +: last-choice ( -- ) plchoice get pop continue ; + +: rules ( -- vector ) pldb get ; +: rule ( n -- rule ) dup rules length >= [ drop "No." ] [ rules nth ] if ; + +: var? ( pl-obj -- ? ) + dup string? [ 0 swap nth LETTER? ] [ drop f ] if ; +: const? ( pl-obj -- ? ) var? not ; + +: check-arity ( pat fact -- pattern fact ? ) 2dup [ length ] 2apply = ; +: check-elements ( pat fact -- ? ) [ over var? [ 2drop t ] [ = ] if ] 2all? ; +: (double-bound) ( key value assoc -- ? ) + pick over at* [ pick = >r 3drop r> ] [ drop swapd set-at t ] if ; +: single-bound? ( pat-d pat-f -- ? ) + H{ } clone [ (double-bound) ] curry 2all? ; +: match-pattern ( pat fact -- ? ) + check-arity [ 2dup check-elements -rot single-bound? and ] [ 2drop f ] if ; +: good-result? ( pat fact -- pat fact ? ) + 2dup dup "No." = [ 2drop t ] [ match-pattern ] if ; + +: add-rule ( name pat body -- ) 3array rules dup length swap set-nth ; + +: (lookup-rule) ( name num -- pat-f rules ) + dup rule dup "No." = >r 0 swap nth swapd dupd = swapd r> or + [ dup rule [ ] callcc0 add-choice ] when + dup number? [ 1+ (lookup-rule) ] [ 2nip ] if ; + +: add-bindings ( pat-d pat-f binds -- binds ) + clone + [ over var? over const? or + [ 2drop ] [ rot dup >r set-at r> ] if + ] 2reduce ; +: init-binds ( pat-d pat-f -- binds ) V{ } clone add-bindings >alist ; + +: replace-if-bound ( binds elt -- binds elt' ) + over 2dup key? [ at ] [ drop ] if ; +: deep-replace ( binds seq -- binds seq' ) + [ dup var? [ replace-if-bound ] + [ dup array? [ dupd deep-replace nip ] when ] if + ] map ; + +: backtrace? ( result -- ) + dup "No." = [ remove-choice last-choice ] + [ [ last-choice ] unless ] if ; + +: resolve-rule ( pat-d pat-f rule-body -- binds ) + >r 2dup init-binds r> [ deep-replace >quotation call dup backtrace? + dup t = [ drop ] when ] each ; + +: rule>pattern ( rule -- pattern ) 1 swap nth ; +: rule>body ( rule -- body ) 2 swap nth ; + +: binds>fact ( pat-d pat-f binds -- fact ) + [ 2dup key? [ at ] [ drop ] if ] curry map good-result? + [ nip ] [ last-choice ] if ; + +: lookup-rule ( name pat -- fact ) + swap 0 (lookup-rule) dup "No." = + [ nip ] + [ dup rule>pattern swapd check-arity + [ rot rule>body resolve-rule dup -roll binds>fact nip ] [ last-choice ] if + ] if ; + +: binding-resolve ( binds name pat -- binds ) + tuck lookup-rule dup backtrace? swap rot add-bindings ; + +: is ( binds val var -- binds ) rot [ set-at ] keep ; diff --git a/extra/prolog/summary.txt b/extra/prolog/summary.txt new file mode 100644 index 0000000000..48ad1f312e --- /dev/null +++ b/extra/prolog/summary.txt @@ -0,0 +1 @@ +Implementation of an embedded prolog for factor diff --git a/extra/prolog/tags.txt b/extra/prolog/tags.txt new file mode 100644 index 0000000000..458345b533 --- /dev/null +++ b/extra/prolog/tags.txt @@ -0,0 +1 @@ +prolog diff --git a/extra/webapps/pastebin/annotation.furnace b/extra/webapps/pastebin/annotation.furnace index 420c1625f5..791905197e 100755 --- a/extra/webapps/pastebin/annotation.furnace +++ b/extra/webapps/pastebin/annotation.furnace @@ -1,11 +1,11 @@ -<% USING: namespaces io ; %> +<% USING: namespaces io furnace calendar ; %> <h2>Annotation: <% "summary" get write %></h2> <table> <tr><th>Annotation by:</th><td><% "author" get write %></td></tr> <tr><th>Channel:</th><td><% "channel" get write %></td></tr> -<tr><th>Created:</th><td><% "date" get write %></td></tr> +<tr><th>Created:</th><td><% "date" get timestamp>string write %></td></tr> </table> <% "syntax" render-template %> diff --git a/extra/webapps/pastebin/paste-summary.furnace b/extra/webapps/pastebin/paste-summary.furnace index f8938eabca..2840110549 100644 --- a/extra/webapps/pastebin/paste-summary.furnace +++ b/extra/webapps/pastebin/paste-summary.furnace @@ -1,10 +1,14 @@ <% USING: continuations namespaces io kernel math math.parser -furnace webapps.pastebin calendar ; %> +furnace webapps.pastebin calendar sequences ; %> <tr> <td> <a href="<% model get paste-link write %>"> - <% "summary" get write %> + <% + "summary" get + dup empty? [ drop "- no title -" ] when + write + %> </a> </td> <td><% "author" get write %></td>