From f257e8b1d0652b5dcaa549f0c885626aa77b15e6 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Thu, 24 Jun 2010 13:51:38 -0600 Subject: [PATCH 01/28] Rackety original commit: 09f6e5bee4fe98f3e3390aca1b255dd3006d7037 --- collects/datalog/ast.rkt | 2 +- collects/datalog/eval.rkt | 10 +- collects/datalog/info.rkt | 2 +- collects/datalog/lang/reader.rkt | 7 +- collects/datalog/main.rkt | 26 +-- collects/datalog/parse.rkt | 6 +- collects/datalog/pretty.rkt | 4 +- collects/datalog/private/compiler.rkt | 12 +- collects/datalog/private/env.rkt | 4 +- collects/datalog/private/lex.rkt | 2 +- collects/datalog/private/subst.rkt | 6 +- collects/datalog/private/unify.rkt | 6 +- collects/datalog/private/variant.rkt | 6 +- collects/datalog/runtime.rkt | 12 +- collects/datalog/scribblings/datalog.scrbl | 194 ++++++++++----------- collects/datalog/scribblings/utils.rkt | 7 +- collects/datalog/tool/syntax-color.rkt | 4 +- 17 files changed, 153 insertions(+), 157 deletions(-) diff --git a/collects/datalog/ast.rkt b/collects/datalog/ast.rkt index 9e51487..ed41f66 100644 --- a/collects/datalog/ast.rkt +++ b/collects/datalog/ast.rkt @@ -1,4 +1,4 @@ -#lang scheme +#lang racket (define srcloc/c (or/c syntax? diff --git a/collects/datalog/eval.rkt b/collects/datalog/eval.rkt index 2e10fdc..b52537f 100644 --- a/collects/datalog/eval.rkt +++ b/collects/datalog/eval.rkt @@ -1,9 +1,9 @@ -#lang scheme -(require scheme/list +#lang racket +(require racket/list (except-in (planet dherman/pprint:4) empty) - "ast.ss" - "pretty.ss" - "runtime.ss") + "ast.rkt" + "pretty.rkt" + "runtime.rkt") (define current-theory (make-parameter (make-mutable-theory))) diff --git a/collects/datalog/info.rkt b/collects/datalog/info.rkt index e9f35bd..82bc5ce 100644 --- a/collects/datalog/info.rkt +++ b/collects/datalog/info.rkt @@ -4,7 +4,7 @@ (list "An implementation of Datalog as a Racket language.")) (define scribblings '(["scribblings/datalog.scrbl" (multi-page)])) (define categories '(devtools)) -(define primary-file "main.ss") +(define primary-file "main.rkt") (define compile-omit-paths '("tests")) (define release-notes (list)) (define repositories '("4.x")) diff --git a/collects/datalog/lang/reader.rkt b/collects/datalog/lang/reader.rkt index 4155f05..ea94055 100644 --- a/collects/datalog/lang/reader.rkt +++ b/collects/datalog/lang/reader.rkt @@ -1,5 +1,5 @@ (module reader syntax/module-reader - #:language `(planet ,(this-package-version-symbol lang/module)) + #:language 'datalog/lang/module #:read (lambda ([in (current-input-port)]) (let ([ast (parse-program in)]) (list `(#%module-begin ,@ast)))) @@ -12,7 +12,6 @@ ; XXX repl submit (case key [(color-lexer) - (dynamic-require `(planet ,(this-package-version-symbol drscheme/syntax-color)) 'get-syntax-token)] + (dynamic-require `datalog/tool/syntax-color) 'get-syntax-token)] [else (default key defval)])) - (require (planet cce/scheme:6/planet) - "../parse.ss")) \ No newline at end of file + (require "../parse.rkt")) \ No newline at end of file diff --git a/collects/datalog/main.rkt b/collects/datalog/main.rkt index 0bf1fc0..3d4186d 100644 --- a/collects/datalog/main.rkt +++ b/collects/datalog/main.rkt @@ -1,13 +1,13 @@ -#lang scheme -(require "ast.ss" - "parse.ss" - "sexp.ss" - "pretty.ss" - "runtime.ss" - "eval.ss") -(provide (all-from-out "ast.ss" - "parse.ss" - "sexp.ss" - "pretty.ss" - "runtime.ss" - "eval.ss")) \ No newline at end of file +#lang racket +(require "ast.rkt" + "parse.rkt" + "sexp.rkt" + "pretty.rkt" + "runtime.rkt" + "eval.rkt") +(provide (all-from-out "ast.rkt" + "parse.rkt" + "sexp.rkt" + "pretty.rkt" + "runtime.rkt" + "eval.rkt")) \ No newline at end of file diff --git a/collects/datalog/parse.rkt b/collects/datalog/parse.rkt index caa20d0..5c3f116 100644 --- a/collects/datalog/parse.rkt +++ b/collects/datalog/parse.rkt @@ -1,8 +1,8 @@ -#lang scheme +#lang racket (require parser-tools/lex parser-tools/yacc - "private/lex.ss" - "ast.ss") + "private/lex.rkt" + "ast.rkt") #| 5.1 Literals diff --git a/collects/datalog/pretty.rkt b/collects/datalog/pretty.rkt index 167d972..cf1944f 100644 --- a/collects/datalog/pretty.rkt +++ b/collects/datalog/pretty.rkt @@ -1,6 +1,6 @@ -#lang scheme +#lang racket (require (planet dherman/pprint:4) - "ast.ss") + "ast.rkt") (define (format-datum s) (cond diff --git a/collects/datalog/private/compiler.rkt b/collects/datalog/private/compiler.rkt index 79e9209..86fee23 100644 --- a/collects/datalog/private/compiler.rkt +++ b/collects/datalog/private/compiler.rkt @@ -1,9 +1,9 @@ -#lang scheme/base -(require scheme/contract - "../ast.ss" - (for-syntax scheme/base)) -(require (for-template scheme/base - "../eval.ss")) +#lang racket/base +(require racket/contract + "../ast.rkt" + (for-syntax racket/base)) +(require (for-template racket/base + "../eval.rkt")) (define (compile-module asts) (with-syntax ([(s ...) asts]) diff --git a/collects/datalog/private/env.rkt b/collects/datalog/private/env.rkt index 625c93d..8e12bed 100644 --- a/collects/datalog/private/env.rkt +++ b/collects/datalog/private/env.rkt @@ -1,5 +1,5 @@ -#lang scheme -(require "../ast.ss") +#lang racket +(require "../ast.rkt") (define env/c (and/c hash? immutable?)) diff --git a/collects/datalog/private/lex.rkt b/collects/datalog/private/lex.rkt index 59d61fa..459752d 100644 --- a/collects/datalog/private/lex.rkt +++ b/collects/datalog/private/lex.rkt @@ -1,4 +1,4 @@ -#lang scheme +#lang racket (require parser-tools/lex (prefix-in : parser-tools/lex-sre)) diff --git a/collects/datalog/private/subst.rkt b/collects/datalog/private/subst.rkt index b5fade6..3ec3581 100644 --- a/collects/datalog/private/subst.rkt +++ b/collects/datalog/private/subst.rkt @@ -1,6 +1,6 @@ -#lang scheme -(require "../ast.ss" - "env.ss") +#lang racket +(require "../ast.rkt" + "env.rkt") (define (subst-term env t) (match t diff --git a/collects/datalog/private/unify.rkt b/collects/datalog/private/unify.rkt index 354f9be..8943e27 100644 --- a/collects/datalog/private/unify.rkt +++ b/collects/datalog/private/unify.rkt @@ -1,6 +1,6 @@ -#lang scheme -(require "../ast.ss" - "env.ss") +#lang racket +(require "../ast.rkt" + "env.rkt") (define (chase env t) (match t diff --git a/collects/datalog/private/variant.rkt b/collects/datalog/private/variant.rkt index 4499654..e28981d 100644 --- a/collects/datalog/private/variant.rkt +++ b/collects/datalog/private/variant.rkt @@ -1,6 +1,6 @@ -#lang scheme -(require "../ast.ss" - "env.ss") +#lang racket +(require "../ast.rkt" + "env.rkt") ; Variants (define (variant-terms env1 env2 ts1 ts2) diff --git a/collects/datalog/runtime.rkt b/collects/datalog/runtime.rkt index 0cca202..e6837b1 100644 --- a/collects/datalog/runtime.rkt +++ b/collects/datalog/runtime.rkt @@ -1,9 +1,9 @@ -#lang scheme -(require "ast.ss" - "private/env.ss" - "private/subst.ss" - "private/unify.ss" - "private/variant.ss") +#lang racket +(require "ast.rkt" + "private/env.rkt" + "private/subst.rkt" + "private/unify.rkt" + "private/variant.rkt") ; A clause is safe if every variable in its head occurs in some literal in its body. (define (safe-clause? c) diff --git a/collects/datalog/scribblings/datalog.scrbl b/collects/datalog/scribblings/datalog.scrbl index 0d10689..ccb4885 100644 --- a/collects/datalog/scribblings/datalog.scrbl +++ b/collects/datalog/scribblings/datalog.scrbl @@ -3,16 +3,14 @@ scribble/eval scribble/basic scribble/bnf - (planet cce/scheme:6/planet) - (planet cce/scheme:6/scribble) (for-label (planet dherman/pprint:4) - scheme/base - scheme/contract - "../main.ss") - "utils.ss") + racket/base + racket/contract + "../main.rkt") + "utils.rkt") @title[#:tag "top"]{@bold{Datalog} for PLT Scheme} -@author[(author+email "Jay McCarthy" "jay@plt-scheme.org")] +@author[(author+email "Jay McCarthy" "jay@racket-lang.org")] This package contains a lightweight deductive database system. Queries and database updates are expressed using @link["http://en.wikipedia.org/wiki/Datalog"]{Datalog}---a declarative logic language in which each @@ -70,7 +68,7 @@ the REPL. Datalog is also available as a module language. This can be used by beginning a Datalog source file with the line: -@(scheme #,(hash-lang) planet #,(this-package-version-symbol)) +@(racket #,(hash-lang) planet #,(this-package-version-symbol)) You can omit the PLaneT version numbers if you prefer. Programs without the version number do not need to be updated when this PLaneT package is upgraded. However, it is then the @@ -83,61 +81,61 @@ Start DrScheme and choose the @tt{Datalog} language from DrScheme's @tt{Language} menu under @tt{Experimental Languages}. Click @onscreen{Run}, then click in the REPL. -@schemeinput[] +@racketinput[] @tech{Facts} are stored in tables. If the name of the table is @litchar["parent"], and @litchar["john"] is the parent of @litchar["douglas"], store the fact in the database with this: -@schemeinput[#,(tt "parent(john, douglas).")] +@racketinput[#,(tt "parent(john, douglas).")] Each item in the parenthesized list following the name of the table is called a @tech{term}. -A term can be either a logical @scheme[variable] or a @scheme[constant]. +A term can be either a logical @racket[variable] or a @racket[constant]. Thus far, all the terms shown have been constant terms. A query can be used to see if a particular row is in a table. Type this to see if @litchar["john"] is the parent of @litchar["douglas"]: -@schemeinput[#,(tt "parent(john, douglas)?")] -@schemeblock[#,(schemeresultfont (tt "parent(john, douglas)."))] +@racketinput[#,(tt "parent(john, douglas)?")] +@racketblock[#,(racketresultfont (tt "parent(john, douglas)."))] Type this to see if @litchar["john"] is the parent of @litchar["ebbon"]: -@schemeinput[#,(tt "parent(john, ebbon)?")] +@racketinput[#,(tt "parent(john, ebbon)?")] The query produced no results because @litchar["john"] is not the parent of @litchar["ebbon"]. Let's add more rows. -@schemeinput[#,(tt "parent(bob, john).")] -@schemeinput[#,(tt "parent(ebbon, bob).")] +@racketinput[#,(tt "parent(bob, john).")] +@racketinput[#,(tt "parent(ebbon, bob).")] Type the following to list all rows in the @litchar["parent"] table: -@schemeinput[#,(tt "parent(A, B)?")] -@schemeblock[#,(schemeresultfont (tt "parent(john, douglas)."))] -@schemeblock[#,(schemeresultfont (tt "parent(bob, john)."))] -@schemeblock[#,(schemeresultfont (tt "parent(ebbon, bob)."))] +@racketinput[#,(tt "parent(A, B)?")] +@racketblock[#,(racketresultfont (tt "parent(john, douglas)."))] +@racketblock[#,(racketresultfont (tt "parent(bob, john)."))] +@racketblock[#,(racketresultfont (tt "parent(ebbon, bob)."))] Type the following to list all the children of @litchar["john"]: -@schemeinput[#,(tt "parent(john, B)?")] -@schemeblock[#,(schemeresultfont (tt "parent(john, douglas)."))] +@racketinput[#,(tt "parent(john, B)?")] +@racketblock[#,(racketresultfont (tt "parent(john, douglas)."))] A term that begins with a capital letter is a logical variable.When producing a set of answers, the Datalog interpreter lists all rows that match the query when each variable in the query is substituted for a constant. The following example produces no answers, as there are no substitutions for the variable @litchar["A"] that produce a fact in the database. This is because no one is the parent of oneself. -@schemeinput[#,(tt "parent(A, A)?")] +@racketinput[#,(tt "parent(A, A)?")] A deductive database can use rules of inference to derive new facts. Consider the following rule: -@schemeinput[#,(tt "ancestor(A, B) :- parent(A, B).")] +@racketinput[#,(tt "ancestor(A, B) :- parent(A, B).")] The rule says that if A is the parent of B, then A is an ancestor of B. The other rule defining an ancestor says that if A is the parent of C, C is an ancestor of B, then A is an ancestor of B. -@schemeinput[#,(tt "ancestor(A, B) :-") +@racketinput[#,(tt "ancestor(A, B) :-") #,(tt " parent(A, C),") #,(tt " ancestor(C, B).")] @@ -145,34 +143,34 @@ In the interpreter, DrScheme knows that the clause is not complete, so by pressi Rules are used to answer queries just as is done for facts. -@schemeinput[#,(tt "ancestor(A, B)?")] -@schemeblock[#,(schemeresultfont (tt "ancestor(ebbon, bob)."))] -@schemeblock[#,(schemeresultfont (tt "ancestor(bob, john)."))] -@schemeblock[#,(schemeresultfont (tt "ancestor(john, douglas)."))] -@schemeblock[#,(schemeresultfont (tt "ancestor(bob, douglas)."))] -@schemeblock[#,(schemeresultfont (tt "ancestor(ebbon, john)."))] -@schemeblock[#,(schemeresultfont (tt "ancestor(ebbon, douglas)."))] -@schemeinput[#,(tt "ancestor(X,john)?")] -@schemeblock[#,(schemeresultfont (tt "ancestor(bob, john)."))] -@schemeblock[#,(schemeresultfont (tt "ancestor(ebbon, john)."))] +@racketinput[#,(tt "ancestor(A, B)?")] +@racketblock[#,(racketresultfont (tt "ancestor(ebbon, bob)."))] +@racketblock[#,(racketresultfont (tt "ancestor(bob, john)."))] +@racketblock[#,(racketresultfont (tt "ancestor(john, douglas)."))] +@racketblock[#,(racketresultfont (tt "ancestor(bob, douglas)."))] +@racketblock[#,(racketresultfont (tt "ancestor(ebbon, john)."))] +@racketblock[#,(racketresultfont (tt "ancestor(ebbon, douglas)."))] +@racketinput[#,(tt "ancestor(X,john)?")] +@racketblock[#,(racketresultfont (tt "ancestor(bob, john)."))] +@racketblock[#,(racketresultfont (tt "ancestor(ebbon, john)."))] A fact or a rule can be retracted from the database using tilde syntax: -@schemeinput[#,(tt "parent(bob, john)~")] -@schemeinput[#,(tt "parent(A, B)?")] -@schemeblock[#,(schemeresultfont (tt "parent(john, douglas)."))] -@schemeblock[#,(schemeresultfont (tt "parent(ebbon, bob)."))] -@schemeinput[#,(tt "ancestor(A, B)?")] -@schemeblock[#,(schemeresultfont (tt "ancestor(ebbon, bob)."))] -@schemeblock[#,(schemeresultfont (tt "ancestor(john, douglas)."))] +@racketinput[#,(tt "parent(bob, john)~")] +@racketinput[#,(tt "parent(A, B)?")] +@racketblock[#,(racketresultfont (tt "parent(john, douglas)."))] +@racketblock[#,(racketresultfont (tt "parent(ebbon, bob)."))] +@racketinput[#,(tt "ancestor(A, B)?")] +@racketblock[#,(racketresultfont (tt "ancestor(ebbon, bob)."))] +@racketblock[#,(racketresultfont (tt "ancestor(john, douglas)."))] Unlike Prolog, the order in which clauses are asserted is irrelevant. All queries terminate, and every possible answer is derived. -@schemeinput[#,(tt "q(X) :- p(X).")] -@schemeinput[#,(tt "q(a).")] -@schemeinput[#,(tt "p(X) :- q(X).")] -@schemeinput[#,(tt "q(X)?")] -@schemeblock[#,(schemeresultfont (tt "q(a)."))] +@racketinput[#,(tt "q(X) :- p(X).")] +@racketinput[#,(tt "q(a).")] +@racketinput[#,(tt "p(X) :- q(X).")] +@racketinput[#,(tt "q(X)?")] +@racketblock[#,(racketresultfont (tt "q(a)."))] @section{Abstract Syntax} @@ -181,10 +179,10 @@ This library provides the structures that represent Datalog syntax. It can be re @defmodule/this-package[ast] @defthing[srcloc/c contract?]{ - Contract for the third argument to @scheme[datum->syntax]. + Contract for the third argument to @racket[datum->syntax]. Equivalent to - @schemeblock[ + @racketblock[ (or/c syntax? false/c (list/c any/c @@ -197,12 +195,12 @@ This library provides the structures that represent Datalog syntax. It can be re @defthing[datum/c contract?]{ Contract for @deftech{datum}s. - Equivalent to @scheme[(or/c string? symbol?)]. + Equivalent to @racket[(or/c string? symbol?)]. } @defproc[(datum-equal? [d1 datum/c] [d2 datum/c]) boolean?]{ - Equivalent to @scheme[(equal? d1 d2)]. + Equivalent to @racket[(equal? d1 d2)]. @examples[#:eval the-eval (datum-equal? 'sym1 'sym2) @@ -220,7 +218,7 @@ This library provides the structures that represent Datalog syntax. It can be re @defproc[(variable-equal? [v1 variable?] [v2 variable?]) boolean?]{ - Equivalent to @scheme[(equal? v1 v2)] modulo source location. + Equivalent to @racket[(equal? v1 v2)] modulo source location. @examples[#:eval the-eval (variable-equal? (make-variable #f 'sym) @@ -238,7 +236,7 @@ This library provides the structures that represent Datalog syntax. It can be re @defproc[(constant-equal? [c1 constant?] [c2 constant?]) boolean?]{ - Equivalent to @scheme[(equal? c1 c2)] modulo source location. + Equivalent to @racket[(equal? c1 c2)] modulo source location. @examples[#:eval the-eval (constant-equal? (make-constant #f 'sym) @@ -248,12 +246,12 @@ This library provides the structures that represent Datalog syntax. It can be re } @defthing[term/c contract?]{ - Contract for @deftech{term}s. Equivalent to @scheme[(or/c variable? constant?)]. + Contract for @deftech{term}s. Equivalent to @racket[(or/c variable? constant?)]. } @defproc[(term-equal? [t1 term/c] [t2 term/c]) boolean?]{ - Equivalent to @scheme[(equal? t1 t2)] modulo source location. + Equivalent to @racket[(equal? t1 t2)] modulo source location. @examples[#:eval the-eval (term-equal? (make-constant #f 'sym) (make-constant #'sym 'sym)) @@ -268,7 +266,7 @@ This library provides the structures that represent Datalog syntax. It can be re @defproc[(literal-equal? [l1 literal?] [l2 literal?]) boolean?]{ - Equivalent to @scheme[(equal? l1 l2)] modulo source location. + Equivalent to @racket[(equal? l1 l2)] modulo source location. @examples[#:eval the-eval (literal-equal? (make-literal #f 'ancestor (list)) @@ -288,7 +286,7 @@ This library provides the structures that represent Datalog syntax. It can be re @defproc[(clause-equal? [c1 clause?] [c2 clause?]) boolean?]{ - Equivalent to @scheme[(equal? c1 c2)] modulo source location. + Equivalent to @racket[(equal? c1 c2)] modulo source location. @examples[#:eval the-eval (clause-equal? @@ -317,12 +315,12 @@ This library provides the structures that represent Datalog syntax. It can be re @defthing[statement/c contract?]{ Contract for @deftech{statement}s. - Equivalent to @scheme[(or/c assertion? retraction? query?)]. + Equivalent to @racket[(or/c assertion? retraction? query?)]. } @defthing[program/c contract?]{ Contract for @deftech{program}s. - Equivalent to @scheme[(listof statement/c)]. + Equivalent to @racket[(listof statement/c)]. } @section{Lexing and Parsing} @@ -432,7 +430,7 @@ The following BNF describes the syntax of Datalog. @defproc[(parse-literal [ip input-port?]) literal?]{ - Parses a @scheme[literal] from @scheme[ip]. + Parses a @racket[literal] from @racket[ip]. @examples[#:eval the-eval (parse-literal (open-input-string "parent(john,douglas)")) @@ -445,7 +443,7 @@ The following BNF describes the syntax of Datalog. @defproc[(parse-clause [ip input-port?]) clause?]{ - Parses a @scheme[clause] from @scheme[ip]. + Parses a @racket[clause] from @racket[ip]. @examples[#:eval the-eval (parse-clause @@ -460,7 +458,7 @@ The following BNF describes the syntax of Datalog. @defproc[(parse-statement [ip input-port?]) statement/c]{ - Parses a @tech{statement} from @scheme[ip]. + Parses a @tech{statement} from @racket[ip]. @examples[#:eval the-eval (parse-statement @@ -473,7 +471,7 @@ The following BNF describes the syntax of Datalog. @defproc[(parse-program [ip input-port?]) program/c]{ - Parses a @tech{program} from @scheme[ip]. + Parses a @tech{program} from @racket[ip]. @examples[#:eval the-eval (parse-program @@ -494,7 +492,7 @@ This package recognizes an alternative, Scheme-like front-end syntax for Datalog @subsection{Parenthetical Datalog Syntax} -@schemegrammar*[ +@racketgrammar*[ #:literals (:- ! ~ ?) [program (begin statement ...)] [statement assertion @@ -517,30 +515,30 @@ This package recognizes an alternative, Scheme-like front-end syntax for Datalog @defproc[(stx->term [stx syntax?]) term/c]{ - Parses @scheme[stx] as a @tech{term}. + Parses @racket[stx] as a @tech{term}. } @defproc[(stx->literal [stx syntax?]) literal?]{ - Parses @scheme[stx] as a @scheme[literal]. + Parses @racket[stx] as a @racket[literal]. } @defproc[(stx->clause [stx syntax?]) clause?]{ - Parses @scheme[stx] as a @scheme[clause]. + Parses @racket[stx] as a @racket[clause]. } @defproc[(stx->statement [stx syntax?]) statement/c]{ - Parses @scheme[stx] as a @tech{statement}. + Parses @racket[stx] as a @tech{statement}. } @defproc[(stx->program [stx syntax?]) program/c]{ - Parses @scheme[stx] as a @tech{program}. + Parses @racket[stx] as a @tech{program}. } -@defproc[(sexp->term [sexp sexpr?]) term/c]{@scheme[stx->term] composed with @scheme[datum->syntax].} -@defproc[(sexp->literal [sexp sexpr?]) literal?]{@scheme[stx->literal] composed with @scheme[datum->syntax].} -@defproc[(sexp->clause [sexp sexpr?]) clause?]{@scheme[stx->clause] composed with @scheme[datum->syntax].} -@defproc[(sexp->statement [sexp sexpr?]) statement/c]{@scheme[stx->statement] composed with @scheme[datum->syntax].} -@defproc[(sexp->program [sexp sexpr?]) program/c]{@scheme[stx->program] composed with @scheme[datum->syntax].} +@defproc[(sexp->term [sexp sexpr?]) term/c]{@racket[stx->term] composed with @racket[datum->syntax].} +@defproc[(sexp->literal [sexp sexpr?]) literal?]{@racket[stx->literal] composed with @racket[datum->syntax].} +@defproc[(sexp->clause [sexp sexpr?]) clause?]{@racket[stx->clause] composed with @racket[datum->syntax].} +@defproc[(sexp->statement [sexp sexpr?]) statement/c]{@racket[stx->statement] composed with @racket[datum->syntax].} +@defproc[(sexp->program [sexp sexpr?]) program/c]{@racket[stx->program] composed with @racket[datum->syntax].} @section{Pretty-Printing} @@ -550,7 +548,7 @@ This library provides facilities for pretty-printing Datalog source. It can be r This library depends on the @tt{pprint} PLaneT package, which can be required via: -@schemeblock[(require (planet dherman/pprint:4))] +@racketblock[(require (planet dherman/pprint:4))] See the documentation for @tt{pprint} for information on how to use it. @@ -565,7 +563,7 @@ See the documentation for @tt{pprint} for information on how to use it. @defproc[(format-variable [v variable?]) doc?]{ - Formats a @scheme[variable]. + Formats a @racket[variable]. @examples[#:eval the-eval (pretty-print (format-variable (make-variable #f 'Ancestor)))] @@ -573,7 +571,7 @@ See the documentation for @tt{pprint} for information on how to use it. @defproc[(format-constant [c constant?]) doc?]{ - Formats a @scheme[constant]. + Formats a @racket[constant]. @examples[#:eval the-eval (pretty-print (format-constant (make-constant #f 'joseph))) @@ -592,7 +590,7 @@ See the documentation for @tt{pprint} for information on how to use it. @defproc[(format-literal [l literal?]) doc?]{ - Formats a @scheme[literal]. + Formats a @racket[literal]. @examples[#:eval the-eval (pretty-print (format-literal (make-literal #f 'true (list)))) @@ -608,7 +606,7 @@ See the documentation for @tt{pprint} for information on how to use it. @defproc[(format-literals [ls (listof literal?)]) doc?]{ - Formats a list of @scheme[literal]s as @scheme[assertion]s for formatting @scheme[prove] results. + Formats a list of @racket[literal]s as @racket[assertion]s for formatting @racket[prove] results. @examples[#:eval the-eval (pretty-print @@ -623,7 +621,7 @@ See the documentation for @tt{pprint} for information on how to use it. @defproc[(format-clause [c clause?]) doc?]{ - Formats a @scheme[clause]. + Formats a @racket[clause]. @examples[#:eval the-eval (pretty-print @@ -658,7 +656,7 @@ See the documentation for @tt{pprint} for information on how to use it. @defproc[(format-assertion [a assertion?]) doc?]{ - Formats a @scheme[assertion]. + Formats a @racket[assertion]. @examples[#:eval the-eval (pretty-print @@ -673,7 +671,7 @@ See the documentation for @tt{pprint} for information on how to use it. @defproc[(format-retraction [r retraction?]) doc?]{ - Formats a @scheme[retraction]. + Formats a @racket[retraction]. @examples[#:eval the-eval (pretty-print @@ -688,7 +686,7 @@ See the documentation for @tt{pprint} for information on how to use it. @defproc[(format-query [q query?]) doc?]{ - Formats a @scheme[query]. + Formats a @racket[query]. @examples[#:eval the-eval (pretty-print @@ -762,8 +760,8 @@ This library implements the Datalog runtime system. It can be required via: @defproc[(safe-clause? [c clause?]) boolean?]{ - Determines if a @scheme[clause] is safe. - A @scheme[clause] is safe if every @scheme[variable] in its head occurs in some @scheme[literal] in its body. + Determines if a @racket[clause] is safe. + A @racket[clause] is safe if every @racket[variable] in its head occurs in some @racket[literal] in its body. @examples[#:eval the-eval (safe-clause? @@ -779,31 +777,31 @@ This library implements the Datalog runtime system. It can be required via: @defproc[(assume [thy immutable-theory/c] [c safe-clause?]) immutable-theory/c]{ - Adds @scheme[c] to @scheme[thy] in a persistent way. + Adds @racket[c] to @racket[thy] in a persistent way. } @defproc[(retract [thy immutable-theory/c] [c clause?]) immutable-theory/c]{ - Removes @scheme[c] from @scheme[thy] in a persistent way. + Removes @racket[c] from @racket[thy] in a persistent way. } @defproc[(assume! [thy mutable-theory/c] [c safe-clause?]) mutable-theory/c]{ - Adds @scheme[c] to @scheme[thy]. + Adds @racket[c] to @racket[thy]. } @defproc[(retract! [thy mutable-theory/c] [c clause?]) mutable-theory/c]{ - Removes @scheme[c] from @scheme[thy]. + Removes @racket[c] from @racket[thy]. } @defproc[(prove [thy theory/c] [l literal?]) (listof literal?)]{ - Attempts to prove @scheme[l] using the @tech{theory} @scheme[thy], returning all + Attempts to prove @racket[l] using the @tech{theory} @racket[thy], returning all the results of the query. @examples[#:eval the-eval @@ -842,14 +840,14 @@ This library provides facilities for evaluating Datalog. It can be required via: @defmodule/this-package[eval] @defthing[current-theory (parameter/c mutable-theory/c)]{ - The @tech{theory} used by @scheme[eval-program] and @scheme[eval-stmt]. + The @tech{theory} used by @racket[eval-program] and @racket[eval-stmt]. } @defproc[(eval-program [p program/c]) void]{ - Evaluates @scheme[p] using @scheme[(current-theory)] as the @tech{theory}, printing query answers as it goes. + Evaluates @racket[p] using @racket[(current-theory)] as the @tech{theory}, printing query answers as it goes. - This will raise a syntax error if given an @scheme[assertion] of a @scheme[clause] that is not a @scheme[safe-clause?]. + This will raise a syntax error if given an @racket[assertion] of a @racket[clause] that is not a @racket[safe-clause?]. @examples[#:eval the-eval (parameterize ([current-theory (make-mutable-theory)]) @@ -869,9 +867,9 @@ This library provides facilities for evaluating Datalog. It can be required via: @defproc[(eval-statement [s statement/c]) (or/c void (listof literal?))]{ - Evaluates @scheme[s] using @scheme[(current-theory)] as the @tech{theory}. + Evaluates @racket[s] using @racket[(current-theory)] as the @tech{theory}. - This will raise a syntax error if given an @scheme[assertion] of a @scheme[clause] that is not a @scheme[safe-clause?]. + This will raise a syntax error if given an @racket[assertion] of a @racket[clause] that is not a @racket[safe-clause?]. @examples[#:eval the-eval (parameterize ([current-theory (make-mutable-theory)]) @@ -895,9 +893,9 @@ This library provides facilities for evaluating Datalog. It can be required via: @defproc[(eval-program/fresh [p program/c]) immutable-theory/c]{ - Evaluates @scheme[p] in a fresh @tech{theory} and returns the final @tech{theory}, printing query answers as it goes. + Evaluates @racket[p] in a fresh @tech{theory} and returns the final @tech{theory}, printing query answers as it goes. - This will raise a syntax error if given an @scheme[assertion] of a @scheme[clause] that is not a @scheme[safe-clause?]. + This will raise a syntax error if given an @racket[assertion] of a @racket[clause] that is not a @racket[safe-clause?]. @examples[#:eval the-eval (void @@ -919,7 +917,7 @@ This library provides facilities for evaluating Datalog. It can be required via: @section{Acknowledgments} -This package is based on Dave Herman's @schememodname[(planet dherman/javascript)] library and +This package is based on Dave Herman's @racketmodname[(planet dherman/javascript)] library and John Ramsdell's @link["http://www.ccs.neu.edu/home/ramsdell/tools/datalog/datalog.html"]{Datalog library}. The package uses the tabled logic programming algorithm described in diff --git a/collects/datalog/scribblings/utils.rkt b/collects/datalog/scribblings/utils.rkt index f4c281c..36503e1 100644 --- a/collects/datalog/scribblings/utils.rkt +++ b/collects/datalog/scribblings/utils.rkt @@ -1,11 +1,10 @@ -#lang scheme/base +#lang racket/base -(require scribble/eval - (planet cce/scheme:6/planet)) +(require scribble/eval) (provide the-eval) (define the-eval (let ([the-eval (make-base-eval)]) - (the-eval `(require (planet ,(this-package-version-symbol)))) + (the-eval `(require datalog)) the-eval)) diff --git a/collects/datalog/tool/syntax-color.rkt b/collects/datalog/tool/syntax-color.rkt index c81e3e4..6078175 100644 --- a/collects/datalog/tool/syntax-color.rkt +++ b/collects/datalog/tool/syntax-color.rkt @@ -1,7 +1,7 @@ -#lang scheme +#lang racket (require parser-tools/lex (prefix-in : parser-tools/lex-sre) - "../private/lex.ss") + "../private/lex.rkt") (provide get-syntax-token) From 43cf5339a277f1807b4326acf3dd340dc796f041 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Thu, 24 Jun 2010 14:12:50 -0600 Subject: [PATCH 02/28] Typo original commit: 4bb6c1ddcfcfe401986b0d2223ea6fd11ca61079 --- collects/datalog/lang/reader.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/datalog/lang/reader.rkt b/collects/datalog/lang/reader.rkt index ea94055..8cf7d2a 100644 --- a/collects/datalog/lang/reader.rkt +++ b/collects/datalog/lang/reader.rkt @@ -12,6 +12,6 @@ ; XXX repl submit (case key [(color-lexer) - (dynamic-require `datalog/tool/syntax-color) 'get-syntax-token)] + (dynamic-require `datalog/tool/syntax-color 'get-syntax-token)] [else (default key defval)])) (require "../parse.rkt")) \ No newline at end of file From 3c1a55e7bbd3c5d22c305927d374d4d24d5fbc50 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Thu, 24 Jun 2010 14:31:30 -0600 Subject: [PATCH 03/28] Removing pprint dependency original commit: 353ef05902eedb148cb6c5b0391b58696c57162a --- collects/datalog/eval.rkt | 2 +- collects/datalog/pretty.rkt | 2 +- collects/datalog/private/pprint.rkt | 23 +++++++++++++++++++ collects/datalog/scribblings/datalog.scrbl | 26 ++++++++-------------- 4 files changed, 34 insertions(+), 19 deletions(-) create mode 100644 collects/datalog/private/pprint.rkt diff --git a/collects/datalog/eval.rkt b/collects/datalog/eval.rkt index b52537f..1c5c827 100644 --- a/collects/datalog/eval.rkt +++ b/collects/datalog/eval.rkt @@ -1,6 +1,6 @@ #lang racket (require racket/list - (except-in (planet dherman/pprint:4) empty) + "private/pprint.rkt" "ast.rkt" "pretty.rkt" "runtime.rkt") diff --git a/collects/datalog/pretty.rkt b/collects/datalog/pretty.rkt index cf1944f..92c8120 100644 --- a/collects/datalog/pretty.rkt +++ b/collects/datalog/pretty.rkt @@ -1,5 +1,5 @@ #lang racket -(require (planet dherman/pprint:4) +(require "private/pprint.rkt" "ast.rkt") (define (format-datum s) diff --git a/collects/datalog/private/pprint.rkt b/collects/datalog/private/pprint.rkt new file mode 100644 index 0000000..92924ef --- /dev/null +++ b/collects/datalog/private/pprint.rkt @@ -0,0 +1,23 @@ +#lang racket +(provide (all-defined-out)) + +(define (pretty-print s) (display s) (newline)) +(define (pretty-format s) s) + +(define (text s) s) +(define (h-append . ss) (apply string-append ss)) +(define (v-concat/s ss) + (apply string-append (add-between ss "\n"))) +(define (v-concat ss) + (v-concat/s ss)) +(define (apply-infix d ds) + (add-between ds d)) +(define line "\n") +(define comma ",") +(define space " ") +(define lparen "(") +(define rparen ")") +(define dot ".") +(define (nest n d) d) +(define char string) +(define doc? string?) \ No newline at end of file diff --git a/collects/datalog/scribblings/datalog.scrbl b/collects/datalog/scribblings/datalog.scrbl index ccb4885..a9bd946 100644 --- a/collects/datalog/scribblings/datalog.scrbl +++ b/collects/datalog/scribblings/datalog.scrbl @@ -3,8 +3,7 @@ scribble/eval scribble/basic scribble/bnf - (for-label (planet dherman/pprint:4) - racket/base + (for-label racket/base racket/contract "../main.rkt") "utils.rkt") @@ -26,7 +25,7 @@ on tabling intermediate results ensures that all queries terminate. The easiest way to get started using Datalog for PLT Scheme is with the main module: -@defmodule/this-package[] +@defmodule[datalog] This module provides everything in the entire package. Subsequent sections of this manual describe the functionality of the individual libraries included, which can also be @@ -47,7 +46,6 @@ parent(ebbon, bob). ancestor(A, B)? END ) - (require (planet dherman/pprint)) (pretty-print (format-program (parse-program @@ -68,7 +66,7 @@ the REPL. Datalog is also available as a module language. This can be used by beginning a Datalog source file with the line: -@(racket #,(hash-lang) planet #,(this-package-version-symbol)) +@defmodulelang[datalog] You can omit the PLaneT version numbers if you prefer. Programs without the version number do not need to be updated when this PLaneT package is upgraded. However, it is then the @@ -176,7 +174,7 @@ Unlike Prolog, the order in which clauses are asserted is irrelevant. All querie This library provides the structures that represent Datalog syntax. It can be required via: -@defmodule/this-package[ast] +@defmodule[datalog/ast] @defthing[srcloc/c contract?]{ Contract for the third argument to @racket[datum->syntax]. @@ -327,7 +325,7 @@ This library provides the structures that represent Datalog syntax. It can be re This library provides facilities for parsing Datalog source. It can be required via: -@defmodule/this-package[parse] +@defmodule[datalog/parse] @subsection{Datalog Syntax} @@ -488,7 +486,7 @@ The following BNF describes the syntax of Datalog. This package recognizes an alternative, Scheme-like front-end syntax for Datalog. It can be required via: -@defmodule/this-package[sexp] +@defmodule[datalog/sexp] @subsection{Parenthetical Datalog Syntax} @@ -544,13 +542,7 @@ This package recognizes an alternative, Scheme-like front-end syntax for Datalog This library provides facilities for pretty-printing Datalog source. It can be required via: -@defmodule/this-package[pretty] - -This library depends on the @tt{pprint} PLaneT package, which can be required via: - -@racketblock[(require (planet dherman/pprint:4))] - -See the documentation for @tt{pprint} for information on how to use it. +@defmodule[datalog/pretty] @defproc[(format-datum [d datum/c]) doc?]{ @@ -734,7 +726,7 @@ See the documentation for @tt{pprint} for information on how to use it. This library implements the Datalog runtime system. It can be required via: -@defmodule/this-package[runtime] +@defmodule[datalog/runtime] @defthing[theory/c contract?]{ A contract for @deftech{theories}. @@ -837,7 +829,7 @@ This library implements the Datalog runtime system. It can be required via: This library provides facilities for evaluating Datalog. It can be required via: -@defmodule/this-package[eval] +@defmodule[datalog/eval] @defthing[current-theory (parameter/c mutable-theory/c)]{ The @tech{theory} used by @racket[eval-program] and @racket[eval-stmt]. From aaa66de05a34fc637cafe819860639e7b401feee Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Thu, 24 Jun 2010 14:33:57 -0600 Subject: [PATCH 04/28] Cleaning up printer original commit: 80da9872e0b0aad0890988dcead6badeaa5f20dc --- collects/datalog/private/pprint.rkt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/datalog/private/pprint.rkt b/collects/datalog/private/pprint.rkt index 92924ef..b26f7ee 100644 --- a/collects/datalog/private/pprint.rkt +++ b/collects/datalog/private/pprint.rkt @@ -7,9 +7,9 @@ (define (text s) s) (define (h-append . ss) (apply string-append ss)) (define (v-concat/s ss) - (apply string-append (add-between ss "\n"))) + (apply string-append ss)) (define (v-concat ss) - (v-concat/s ss)) + (apply string-append (add-between ss "\n"))) (define (apply-infix d ds) (add-between ds d)) (define line "\n") From 83e858254fb1e2f5c8a32a51c7d4ab15de65d57a Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Thu, 24 Jun 2010 15:10:24 -0600 Subject: [PATCH 05/28] Removing tool and using new repl submit original commit: ee8477ca137c333508a43f4e039e63082d0b64c1 --- collects/datalog/lang/reader.rkt | 7 ++-- collects/datalog/tool/submit.rkt | 54 ++++++++++++++++++++++++++ collects/datalog/tool/syntax-color.rkt | 8 ++-- 3 files changed, 62 insertions(+), 7 deletions(-) create mode 100644 collects/datalog/tool/submit.rkt diff --git a/collects/datalog/lang/reader.rkt b/collects/datalog/lang/reader.rkt index 8cf7d2a..701c0c8 100644 --- a/collects/datalog/lang/reader.rkt +++ b/collects/datalog/lang/reader.rkt @@ -6,11 +6,12 @@ #:read-syntax (lambda ([source-name #f] [in (current-input-port)]) (let ([ast (parse-program in)]) (list `(#%module-begin ,@ast)))) - #:whole-body-readers? #t + #:whole-body-readers? #t #:info (lambda (key defval default) - ; XXX Should have comment character key - ; XXX repl submit + ; XXX Should have different comment character key (case key + [(drracket:submit-predicate) + (dynamic-require `datalog/tool/submit 'repl-submit?)] [(color-lexer) (dynamic-require `datalog/tool/syntax-color 'get-syntax-token)] [else (default key defval)])) diff --git a/collects/datalog/tool/submit.rkt b/collects/datalog/tool/submit.rkt new file mode 100644 index 0000000..f16281a --- /dev/null +++ b/collects/datalog/tool/submit.rkt @@ -0,0 +1,54 @@ +#lang racket/base + +(define (delimiter-pair? x y) + (and (char=? x #\() (char=? y #\)))) + +(define (repl-submit? ip has-white-space?) + (let loop ([blank? #t] + [string-char #f] + [delimiter-stack null] + [closed? #f]) + (let ([c (read-char ip)]) + (if (eof-object? c) + (and closed? + (not blank?) + (not string-char) + (null? delimiter-stack)) + (case c + [(#\. #\? #\~) + (if string-char + (loop #f string-char delimiter-stack #f) + (loop #f #f delimiter-stack #t))] + [(#\() + (if string-char + (loop #f string-char delimiter-stack #f) + (loop #f #f (cons c delimiter-stack) #f))] + [(#\)) + (cond + [string-char + (loop #f string-char delimiter-stack #f)] + [(and (pair? delimiter-stack) + (delimiter-pair? (car delimiter-stack) c)) + (loop #f #f (cdr delimiter-stack) #f)] + [else + (loop #f #f delimiter-stack #f)])] + [(#\") + (cond + [(and string-char (char=? c string-char)) + (loop #f #f delimiter-stack #f)] + [string-char + (loop #f string-char delimiter-stack #f)] + [else + (loop #f c delimiter-stack #f)])] + [(#\\) + (if string-char + (begin (read-char ip) + (loop #f string-char delimiter-stack #f)) + (loop #f string-char delimiter-stack #f))] + [else + (loop (and blank? (char-whitespace? c)) + string-char + delimiter-stack + closed?)]))))) + +(provide repl-submit?) \ No newline at end of file diff --git a/collects/datalog/tool/syntax-color.rkt b/collects/datalog/tool/syntax-color.rkt index 6078175..5966b2e 100644 --- a/collects/datalog/tool/syntax-color.rkt +++ b/collects/datalog/tool/syntax-color.rkt @@ -1,4 +1,4 @@ -#lang racket +#lang racket/base (require parser-tools/lex (prefix-in : parser-tools/lex-sre) "../private/lex.rkt") @@ -26,11 +26,11 @@ [comment-re (syn-val lexeme 'comment #f start-pos end-pos)] [variable-re - (syn-val lexeme 'identifier #f start-pos end-pos)] + (syn-val lexeme 'symbol #f start-pos end-pos)] [identifier-re - (syn-val lexeme 'keyword #f start-pos end-pos)] + (syn-val lexeme 'identifier #f start-pos end-pos)] [(:or #\) #\() (syn-val lexeme 'parenthesis #f start-pos end-pos)] - [(:or #\= #\? #\~ #\. #\, ":-") (syn-val lexeme 'default #f start-pos end-pos)] + [(:or #\= #\? #\~ #\. #\, ":-") (syn-val lexeme 'parenthesis #f start-pos end-pos)] [(eof) (syn-val lexeme 'eof #f start-pos end-pos)] [#\" ((colorize-string start-pos) input-port)] [any-char (syn-val lexeme 'error #f start-pos end-pos)])) \ No newline at end of file From 80a32fb213f813048f0a9f881fa234f9c002e2ba Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Thu, 24 Jun 2010 15:17:44 -0600 Subject: [PATCH 06/28] Clean up original commit: 33f5d9059243e434d2677118d7b974dea190e5f5 --- collects/datalog/eval.rkt | 5 +- collects/datalog/private/pprint.rkt | 3 - collects/datalog/scribblings/datalog.scrbl | 93 +++++++++------------- 3 files changed, 41 insertions(+), 60 deletions(-) diff --git a/collects/datalog/eval.rkt b/collects/datalog/eval.rkt index 1c5c827..38de442 100644 --- a/collects/datalog/eval.rkt +++ b/collects/datalog/eval.rkt @@ -1,6 +1,5 @@ #lang racket (require racket/list - "private/pprint.rkt" "ast.rkt" "pretty.rkt" "runtime.rkt") @@ -13,10 +12,10 @@ (assume thy c) (raise-syntax-error 'datalog "Unsafe clause in assertion" - (datum->syntax #f (pretty-format (format-statement s)) (assertion-srcloc s)))))) + (datum->syntax #f (format-statement s) (assertion-srcloc s)))))) (define (print-literals ls) - (pretty-print + (displayln (format-literals ls))) (define (eval-program p) diff --git a/collects/datalog/private/pprint.rkt b/collects/datalog/private/pprint.rkt index b26f7ee..faf3476 100644 --- a/collects/datalog/private/pprint.rkt +++ b/collects/datalog/private/pprint.rkt @@ -1,9 +1,6 @@ #lang racket (provide (all-defined-out)) -(define (pretty-print s) (display s) (newline)) -(define (pretty-format s) s) - (define (text s) s) (define (h-append . ss) (apply string-append ss)) (define (v-concat/s ss) diff --git a/collects/datalog/scribblings/datalog.scrbl b/collects/datalog/scribblings/datalog.scrbl index a9bd946..c2e8d29 100644 --- a/collects/datalog/scribblings/datalog.scrbl +++ b/collects/datalog/scribblings/datalog.scrbl @@ -46,11 +46,10 @@ parent(ebbon, bob). ancestor(A, B)? END ) - (pretty-print - (format-program + (format-program (parse-program (open-input-string - example-program)))) + example-program))) (void (eval-program/fresh (parse-program @@ -549,8 +548,8 @@ This library provides facilities for pretty-printing Datalog source. It can be r Formats a @tech{datum}. @examples[#:eval the-eval - (pretty-print (format-datum 'sym)) - (pretty-print (format-datum "str"))] + (format-datum 'sym) + (format-datum "str")] } @defproc[(format-variable [v variable?]) @@ -558,7 +557,7 @@ This library provides facilities for pretty-printing Datalog source. It can be r Formats a @racket[variable]. @examples[#:eval the-eval - (pretty-print (format-variable (make-variable #f 'Ancestor)))] + (format-variable (make-variable #f 'Ancestor))] } @defproc[(format-constant [c constant?]) @@ -566,8 +565,8 @@ This library provides facilities for pretty-printing Datalog source. It can be r Formats a @racket[constant]. @examples[#:eval the-eval - (pretty-print (format-constant (make-constant #f 'joseph))) - (pretty-print (format-constant (make-constant #f "whom")))] + (format-constant (make-constant #f 'joseph)) + (format-constant (make-constant #f "whom"))] } @defproc[(format-term [t term/c]) @@ -575,9 +574,9 @@ This library provides facilities for pretty-printing Datalog source. It can be r Formats a @tech{term}. @examples[#:eval the-eval - (pretty-print (format-term (make-variable #f 'Ancestor))) - (pretty-print (format-term (make-constant #f 'joseph))) - (pretty-print (format-term (make-constant #f "whom")))] + (format-term (make-variable #f 'Ancestor)) + (format-term (make-constant #f 'joseph)) + (format-term (make-constant #f "whom"))] } @defproc[(format-literal [l literal?]) @@ -585,15 +584,13 @@ This library provides facilities for pretty-printing Datalog source. It can be r Formats a @racket[literal]. @examples[#:eval the-eval - (pretty-print (format-literal (make-literal #f 'true (list)))) - (pretty-print - (format-literal + (format-literal (make-literal #f 'true (list))) + (format-literal (make-literal #f 'ancestor - (list (make-variable #f 'A) (make-constant #f 'jay))))) - (pretty-print - (format-literal + (list (make-variable #f 'A) (make-constant #f 'jay)))) + (format-literal (make-literal #f '= - (list (make-constant #f 'joseph) (make-constant #f 'jay)))))] + (list (make-constant #f 'joseph) (make-constant #f 'jay))))] } @defproc[(format-literals [ls (listof literal?)]) @@ -601,14 +598,13 @@ This library provides facilities for pretty-printing Datalog source. It can be r Formats a list of @racket[literal]s as @racket[assertion]s for formatting @racket[prove] results. @examples[#:eval the-eval - (pretty-print - (format-literals + (format-literals (list (make-literal #f 'true (list)) (make-literal #f 'ancestor (list (make-constant #f 'joseph) (make-constant #f 'jay))) (make-literal #f '= - (list (make-constant #f 'joseph) (make-constant #f 'jay))))))] + (list (make-constant #f 'joseph) (make-constant #f 'jay)))))] } @defproc[(format-clause [c clause?]) @@ -616,24 +612,21 @@ This library provides facilities for pretty-printing Datalog source. It can be r Formats a @racket[clause]. @examples[#:eval the-eval - (pretty-print - (format-clause + ((format-clause (make-clause #f (make-literal #f 'ancestor (list (make-constant #f 'joseph) (make-constant #f 'jay))) - (list)))) - (pretty-print - (format-clause + (list))) + (format-clause (make-clause #f (make-literal #f 'ancestor (list (make-constant #f 'A) (make-constant #f 'B))) (list (make-literal #f 'parent - (list (make-constant #f 'A) (make-constant #f 'B))))))) - (pretty-print - (format-clause + (list (make-constant #f 'A) (make-constant #f 'B)))))) + (format-clause (make-clause #f (make-literal #f 'ancestor @@ -643,7 +636,7 @@ This library provides facilities for pretty-printing Datalog source. It can be r (list (make-constant #f 'A) (make-constant #f 'C))) (make-literal #f 'ancestor - (list (make-constant #f 'C) (make-constant #f 'B)))))))] + (list (make-constant #f 'C) (make-constant #f 'B))))))] } @defproc[(format-assertion [a assertion?]) @@ -651,14 +644,13 @@ This library provides facilities for pretty-printing Datalog source. It can be r Formats a @racket[assertion]. @examples[#:eval the-eval - (pretty-print - (format-assertion + (format-assertion (make-assertion #f (make-clause #f (make-literal #f 'ancestor (list (make-constant #f 'joseph) (make-constant #f 'jay))) - (list)))))] + (list))))] } @defproc[(format-retraction [r retraction?]) @@ -666,14 +658,13 @@ This library provides facilities for pretty-printing Datalog source. It can be r Formats a @racket[retraction]. @examples[#:eval the-eval - (pretty-print - (format-retraction + (format-retraction (make-retraction #f (make-clause #f (make-literal #f 'ancestor (list (make-constant #f 'joseph) (make-constant #f 'jay))) - (list)))))] + (list))))] } @defproc[(format-query [q query?]) @@ -681,12 +672,11 @@ This library provides facilities for pretty-printing Datalog source. It can be r Formats a @racket[query]. @examples[#:eval the-eval - (pretty-print - (format-query + (format-query (make-query #f (make-literal #f 'ancestor (list (make-constant #f 'joseph) - (make-constant #f 'jay))))))] + (make-constant #f 'jay)))))] } @defproc[(format-statement [s statement/c]) @@ -694,12 +684,11 @@ This library provides facilities for pretty-printing Datalog source. It can be r Formats a @tech{statement}. @examples[#:eval the-eval - (pretty-print - (format-statement + (format-statement (make-query #f (make-literal #f 'ancestor (list (make-constant #f 'joseph) - (make-constant #f 'jay))))))] + (make-constant #f 'jay)))))] } @defproc[(format-program [p program/c]) @@ -707,8 +696,7 @@ This library provides facilities for pretty-printing Datalog source. It can be r Formats a @tech{program}. @examples[#:eval the-eval - (pretty-print - (format-program + (format-program (list (make-assertion #f (make-clause @@ -719,7 +707,7 @@ This library provides facilities for pretty-printing Datalog source. It can be r (make-query #f (make-literal #f 'ancestor (list (make-constant #f 'joseph) - (make-constant #f 'jay)))))))] + (make-constant #f 'jay))))))] } @section{Runtime System} @@ -797,16 +785,14 @@ This library implements the Datalog runtime system. It can be required via: the results of the query. @examples[#:eval the-eval - (pretty-print - (format-literals + (format-literals (prove (assume (make-immutable-theory) (parse-clause (open-input-string "parent(joseph1,joseph2)"))) (parse-literal - (open-input-string "parent(joseph1,joseph2)"))))) - (pretty-print - (format-literals + (open-input-string "parent(joseph1,joseph2)")))) + (format-literals (prove (retract (assume @@ -815,14 +801,13 @@ This library implements the Datalog runtime system. It can be required via: (open-input-string "parent(joseph1,joseph2)"))) (parse-clause (open-input-string "parent(joseph1,joseph2)"))) (parse-literal - (open-input-string "parent(joseph1,joseph2)"))))) - (pretty-print - (format-literals + (open-input-string "parent(joseph1,joseph2)")))) + (format-literals (prove (assume (make-immutable-theory) (parse-clause (open-input-string "parent(joseph1,joseph2)"))) - (parse-literal (open-input-string "parent(A,B)")))))] + (parse-literal (open-input-string "parent(A,B)"))))] } @section{Evaluation} From cd74d2dd5b167d2b75c769f343bc126bb4794c22 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Thu, 24 Jun 2010 15:21:51 -0600 Subject: [PATCH 07/28] Typo original commit: e752682879b32883092f8bd9eaa4b4535a029518 --- collects/datalog/scribblings/datalog.scrbl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/datalog/scribblings/datalog.scrbl b/collects/datalog/scribblings/datalog.scrbl index c2e8d29..495dc79 100644 --- a/collects/datalog/scribblings/datalog.scrbl +++ b/collects/datalog/scribblings/datalog.scrbl @@ -612,7 +612,7 @@ This library provides facilities for pretty-printing Datalog source. It can be r Formats a @racket[clause]. @examples[#:eval the-eval - ((format-clause + (format-clause (make-clause #f (make-literal #f 'ancestor (list (make-constant #f 'joseph) From a14e87e56f8e7159442141d74684087d2a6a5bd5 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Thu, 24 Jun 2010 15:31:42 -0600 Subject: [PATCH 08/28] Tests original commit: 73b4059adece873e39485e471deb2079710bdad0 --- collects/datalog/pretty.rkt | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/collects/datalog/pretty.rkt b/collects/datalog/pretty.rkt index 92c8120..e58d7d9 100644 --- a/collects/datalog/pretty.rkt +++ b/collects/datalog/pretty.rkt @@ -27,7 +27,7 @@ [(struct literal (_ pred terms)) (h-append (format-datum pred) lparen - (v-concat/s (apply-infix comma (map format-term terms))) + (v-concat/s (apply-infix ", " (map format-term terms))) rparen)])) (define (format-literals ls) (v-concat @@ -40,8 +40,8 @@ (format-literal (clause-head c)) (nest 4 (v-concat/s - (list* (h-append (format-literal (clause-head c)) space (text ":-")) - (apply-infix comma (map format-literal (clause-body c)))))))) + (list* (h-append (format-literal (clause-head c)) space (text ":-") space) + (apply-infix ", " (map format-literal (clause-body c)))))))) (define (format-assertion a) (h-append (format-clause (assertion-clause a)) dot)) From d7ffe1ef99a0a4d58dfeb467e07e50d20b4a3a05 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Thu, 24 Jun 2010 15:40:19 -0600 Subject: [PATCH 09/28] docs original commit: a98547b033c8036ec5f73754d027f5c992509b74 --- collects/datalog/info.rkt | 11 ++------- collects/datalog/scribblings/datalog.scrbl | 26 +++++++++++----------- 2 files changed, 15 insertions(+), 22 deletions(-) diff --git a/collects/datalog/info.rkt b/collects/datalog/info.rkt index 82bc5ce..aed5db6 100644 --- a/collects/datalog/info.rkt +++ b/collects/datalog/info.rkt @@ -1,10 +1,3 @@ #lang setup/infotab -(define name "Datalog") -(define blurb - (list "An implementation of Datalog as a Racket language.")) -(define scribblings '(["scribblings/datalog.scrbl" (multi-page)])) -(define categories '(devtools)) -(define primary-file "main.rkt") -(define compile-omit-paths '("tests")) -(define release-notes (list)) -(define repositories '("4.x")) +(define scribblings '(["scribblings/datalog.scrbl" (multi-page) (language)])) +(define compile-omit-paths '("tests")) \ No newline at end of file diff --git a/collects/datalog/scribblings/datalog.scrbl b/collects/datalog/scribblings/datalog.scrbl index 495dc79..81b095a 100644 --- a/collects/datalog/scribblings/datalog.scrbl +++ b/collects/datalog/scribblings/datalog.scrbl @@ -8,7 +8,7 @@ "../main.rkt") "utils.rkt") -@title[#:tag "top"]{@bold{Datalog} for PLT Scheme} +@title[#:tag "top"]{@bold{Datalog}: Deductive database programming} @author[(author+email "Jay McCarthy" "jay@racket-lang.org")] This package contains a lightweight deductive database system. Queries and database updates are expressed @@ -544,7 +544,7 @@ This library provides facilities for pretty-printing Datalog source. It can be r @defmodule[datalog/pretty] @defproc[(format-datum [d datum/c]) - doc?]{ + string?]{ Formats a @tech{datum}. @examples[#:eval the-eval @@ -553,7 +553,7 @@ This library provides facilities for pretty-printing Datalog source. It can be r } @defproc[(format-variable [v variable?]) - doc?]{ + string?]{ Formats a @racket[variable]. @examples[#:eval the-eval @@ -561,7 +561,7 @@ This library provides facilities for pretty-printing Datalog source. It can be r } @defproc[(format-constant [c constant?]) - doc?]{ + string?]{ Formats a @racket[constant]. @examples[#:eval the-eval @@ -570,7 +570,7 @@ This library provides facilities for pretty-printing Datalog source. It can be r } @defproc[(format-term [t term/c]) - doc?]{ + string?]{ Formats a @tech{term}. @examples[#:eval the-eval @@ -580,7 +580,7 @@ This library provides facilities for pretty-printing Datalog source. It can be r } @defproc[(format-literal [l literal?]) - doc?]{ + string?]{ Formats a @racket[literal]. @examples[#:eval the-eval @@ -594,7 +594,7 @@ This library provides facilities for pretty-printing Datalog source. It can be r } @defproc[(format-literals [ls (listof literal?)]) - doc?]{ + string?]{ Formats a list of @racket[literal]s as @racket[assertion]s for formatting @racket[prove] results. @examples[#:eval the-eval @@ -608,7 +608,7 @@ This library provides facilities for pretty-printing Datalog source. It can be r } @defproc[(format-clause [c clause?]) - doc?]{ + string?]{ Formats a @racket[clause]. @examples[#:eval the-eval @@ -640,7 +640,7 @@ This library provides facilities for pretty-printing Datalog source. It can be r } @defproc[(format-assertion [a assertion?]) - doc?]{ + string?]{ Formats a @racket[assertion]. @examples[#:eval the-eval @@ -654,7 +654,7 @@ This library provides facilities for pretty-printing Datalog source. It can be r } @defproc[(format-retraction [r retraction?]) - doc?]{ + string?]{ Formats a @racket[retraction]. @examples[#:eval the-eval @@ -668,7 +668,7 @@ This library provides facilities for pretty-printing Datalog source. It can be r } @defproc[(format-query [q query?]) - doc?]{ + string?]{ Formats a @racket[query]. @examples[#:eval the-eval @@ -680,7 +680,7 @@ This library provides facilities for pretty-printing Datalog source. It can be r } @defproc[(format-statement [s statement/c]) - doc?]{ + string?]{ Formats a @tech{statement}. @examples[#:eval the-eval @@ -692,7 +692,7 @@ This library provides facilities for pretty-printing Datalog source. It can be r } @defproc[(format-program [p program/c]) - doc?]{ + string?]{ Formats a @tech{program}. @examples[#:eval the-eval From 1ae2f94781ed14957c4b98f8ce70ecfe385a7fcd Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Fri, 25 Jun 2010 15:29:48 -0600 Subject: [PATCH 10/28] Paren examples original commit: 8636c4ee362add3bad7437b5a062bbb5bd210cc1 --- collects/datalog/scribblings/datalog.scrbl | 757 +------------------- collects/datalog/scribblings/racket.scrbl | 638 +++++++++++++++++ collects/datalog/scribblings/tutorial.scrbl | 106 +++ 3 files changed, 752 insertions(+), 749 deletions(-) create mode 100644 collects/datalog/scribblings/racket.scrbl create mode 100644 collects/datalog/scribblings/tutorial.scrbl diff --git a/collects/datalog/scribblings/datalog.scrbl b/collects/datalog/scribblings/datalog.scrbl index 81b095a..a0973a0 100644 --- a/collects/datalog/scribblings/datalog.scrbl +++ b/collects/datalog/scribblings/datalog.scrbl @@ -19,312 +19,11 @@ on tabling intermediate results ensures that all queries terminate. @table-of-contents[] -@section{Datalog for PLT Scheme} - -@subsection{Getting Started} - -The easiest way to get started using Datalog for PLT Scheme is with the main module: - -@defmodule[datalog] - -This module provides everything in the entire package. Subsequent sections of this -manual describe the functionality of the individual libraries included, which can also be -required individually. - -@examples[#:eval the-eval - (define example-program - #<syntax]. - - Equivalent to - @racketblock[ - (or/c syntax? - false/c - (list/c any/c - (or/c exact-positive-integer? #f) - (or/c exact-nonnegative-integer? #f) - (or/c exact-nonnegative-integer? #f) - (or/c exact-positive-integer? #f))) - ] -} - -@defthing[datum/c contract?]{ - Contract for @deftech{datum}s. - Equivalent to @racket[(or/c string? symbol?)]. -} - -@defproc[(datum-equal? [d1 datum/c] [d2 datum/c]) - boolean?]{ - Equivalent to @racket[(equal? d1 d2)]. - - @examples[#:eval the-eval - (datum-equal? 'sym1 'sym2) - (datum-equal? 'sym1 'sym1) - (datum-equal? "str1" "str2") - (datum-equal? "str1" "str1")] -} - -@defstruct[variable ([srcloc srcloc/c] - [sym symbol?])]{ - A logic variable in Datalog. - (This structure does not enforce the requirements for what characters variables can contain, so if you print one out, - it might not be parseable, but it will be executeable.) -} - -@defproc[(variable-equal? [v1 variable?] [v2 variable?]) - boolean?]{ - Equivalent to @racket[(equal? v1 v2)] modulo source location. - - @examples[#:eval the-eval - (variable-equal? (make-variable #f 'sym) - (make-variable #'sym 'sym)) - (variable-equal? (make-variable #f 'sym1) - (make-variable #f 'sym2))] -} - -@defstruct[constant ([srcloc srcloc/c] - [datum datum/c])]{ - A constant in Datalog. - (This structure does not enforce the requirements for what characters constants can contain, so if you print one out, - it might not be parseable, but it will be executeable.) -} - -@defproc[(constant-equal? [c1 constant?] [c2 constant?]) - boolean?]{ - Equivalent to @racket[(equal? c1 c2)] modulo source location. - - @examples[#:eval the-eval - (constant-equal? (make-constant #f 'sym) - (make-constant #'sym 'sym)) - (constant-equal? (make-constant #f 'sym) - (make-constant #f "str"))] -} - -@defthing[term/c contract?]{ - Contract for @deftech{term}s. Equivalent to @racket[(or/c variable? constant?)]. -} - -@defproc[(term-equal? [t1 term/c] [t2 term/c]) - boolean?]{ - Equivalent to @racket[(equal? t1 t2)] modulo source location. - - @examples[#:eval the-eval - (term-equal? (make-constant #f 'sym) (make-constant #'sym 'sym)) - (term-equal? (make-constant #f 'sym) (make-constant #f "str"))] -} - -@defstruct[literal ([srcloc srcloc/c] - [predicate datum/c] - [terms (listof term/c)])]{ - A literal in Datalog. -} - -@defproc[(literal-equal? [l1 literal?] [l2 literal?]) - boolean?]{ - Equivalent to @racket[(equal? l1 l2)] modulo source location. - - @examples[#:eval the-eval - (literal-equal? (make-literal #f 'ancestor (list)) - (make-literal #'ancestor 'ancestor (list))) - (literal-equal? (make-literal #f 'ancestor (list)) - (make-literal #f 'parent (list))) - (literal-equal? (make-literal #f 'ancestor (list)) - (make-literal #f 'ancestor - (list (make-constant #f 'jack))))] -} - -@defstruct[clause ([srcloc srcloc/c] - [head literal?] - [body (listof literal?)])]{ - A Datalog clause. -} - -@defproc[(clause-equal? [c1 clause?] [c2 clause?]) - boolean?]{ - Equivalent to @racket[(equal? c1 c2)] modulo source location. - - @examples[#:eval the-eval - (clause-equal? - (make-clause #f (make-literal #f 'ancestor (list)) (list)) - (make-clause #'clause - (make-literal #f 'ancestor (list)) (list))) - (clause-equal? - (make-clause #f (make-literal #f 'ancestor (list)) (list)) - (make-clause #f (make-literal #f 'parent (list)) (list)))] -} - -@defstruct[assertion ([srcloc srcloc/c] - [clause clause?])]{ - A Datalog assertion. -} - -@defstruct[retraction ([srcloc srcloc/c] - [clause clause?])]{ - A Datalog retraction. -} - -@defstruct[query ([srcloc srcloc/c] - [clause clause?])]{ - A Datalog query. -} - -@defthing[statement/c contract?]{ - Contract for @deftech{statement}s. - Equivalent to @racket[(or/c assertion? retraction? query?)]. -} - -@defthing[program/c contract?]{ - Contract for @deftech{program}s. - Equivalent to @racket[(listof statement/c)]. -} - -@section{Lexing and Parsing} - -This library provides facilities for parsing Datalog source. It can be required via: - -@defmodule[datalog/parse] +XXX Progress @subsection{Datalog Syntax} @@ -423,74 +122,16 @@ The following BNF describes the syntax of Datalog. (nonterm "STRING")) ] -@subsection{Parser API} +@section{Parenthetical Datalog Module Language} -@defproc[(parse-literal [ip input-port?]) - literal?]{ - Parses a @racket[literal] from @racket[ip]. - - @examples[#:eval the-eval - (parse-literal (open-input-string "parent(john,douglas)")) - (parse-literal (open-input-string "zero-arity-literal")) - (parse-literal (open-input-string "\"=\"(3,3)")) - (parse-literal - (open-input-string "\"\"(-0-0-0,&&&,***,\"\00\")")) - (parse-literal (open-input-string "3 = 3"))] -} - -@defproc[(parse-clause [ip input-port?]) - clause?]{ - Parses a @racket[clause] from @racket[ip]. - - @examples[#:eval the-eval - (parse-clause - (open-input-string "parent(john, douglas)")) - (parse-clause - (open-input-string "ancestor(A, B) :- parent(A, B)")) - (parse-clause - (open-input-string - (string-append "ancestor(A, B) :- parent(A, C)," - "ancestor(C, B)")))] -} - -@defproc[(parse-statement [ip input-port?]) - statement/c]{ - Parses a @tech{statement} from @racket[ip]. - - @examples[#:eval the-eval - (parse-statement - (open-input-string "parent(john, douglas).")) - (parse-statement - (open-input-string "parent(john, douglas)~")) - (parse-statement - (open-input-string "parent(john, douglas)?"))] -} - -@defproc[(parse-program [ip input-port?]) - program/c]{ - Parses a @tech{program} from @racket[ip]. - - @examples[#:eval the-eval - (parse-program - (open-input-string - (string-append - "edge(a, b). edge(b, c)." - "edge(c, d). edge(d, a)." - "path(X, Y) :- edge(X, Y)." - "path(X, Y) :- edge(X, Z), path(Z, Y)." - "path(X, Y)?")))] -} +@defmodulelang[datalog/sexp] -@section{Parenthetical Datalog} - -This package recognizes an alternative, Scheme-like front-end syntax for Datalog. It can be required via: - -@defmodule[datalog/sexp] +XXX Progress @subsection{Parenthetical Datalog Syntax} @racketgrammar*[ - #:literals (:- ! ~ ?) + #:literals (:- ! ~ ? unquote) [program (begin statement ...)] [statement assertion retraction @@ -508,393 +149,11 @@ This package recognizes an alternative, Scheme-like front-end syntax for Datalog [datum symbol string]] -@subsection{Parethetical Parser API} - -@defproc[(stx->term [stx syntax?]) - term/c]{ - Parses @racket[stx] as a @tech{term}. -} -@defproc[(stx->literal [stx syntax?]) - literal?]{ - Parses @racket[stx] as a @racket[literal]. -} -@defproc[(stx->clause [stx syntax?]) - clause?]{ - Parses @racket[stx] as a @racket[clause]. -} -@defproc[(stx->statement [stx syntax?]) - statement/c]{ - Parses @racket[stx] as a @tech{statement}. -} -@defproc[(stx->program [stx syntax?]) - program/c]{ - Parses @racket[stx] as a @tech{program}. -} - -@defproc[(sexp->term [sexp sexpr?]) term/c]{@racket[stx->term] composed with @racket[datum->syntax].} -@defproc[(sexp->literal [sexp sexpr?]) literal?]{@racket[stx->literal] composed with @racket[datum->syntax].} -@defproc[(sexp->clause [sexp sexpr?]) clause?]{@racket[stx->clause] composed with @racket[datum->syntax].} -@defproc[(sexp->statement [sexp sexpr?]) statement/c]{@racket[stx->statement] composed with @racket[datum->syntax].} -@defproc[(sexp->program [sexp sexpr?]) program/c]{@racket[stx->program] composed with @racket[datum->syntax].} - -@section{Pretty-Printing} - -This library provides facilities for pretty-printing Datalog source. It can be required via: - -@defmodule[datalog/pretty] - -@defproc[(format-datum [d datum/c]) - string?]{ - Formats a @tech{datum}. - - @examples[#:eval the-eval - (format-datum 'sym) - (format-datum "str")] -} - -@defproc[(format-variable [v variable?]) - string?]{ - Formats a @racket[variable]. - - @examples[#:eval the-eval - (format-variable (make-variable #f 'Ancestor))] -} - -@defproc[(format-constant [c constant?]) - string?]{ - Formats a @racket[constant]. - - @examples[#:eval the-eval - (format-constant (make-constant #f 'joseph)) - (format-constant (make-constant #f "whom"))] -} - -@defproc[(format-term [t term/c]) - string?]{ - Formats a @tech{term}. - - @examples[#:eval the-eval - (format-term (make-variable #f 'Ancestor)) - (format-term (make-constant #f 'joseph)) - (format-term (make-constant #f "whom"))] -} - -@defproc[(format-literal [l literal?]) - string?]{ - Formats a @racket[literal]. - - @examples[#:eval the-eval - (format-literal (make-literal #f 'true (list))) - (format-literal - (make-literal #f 'ancestor - (list (make-variable #f 'A) (make-constant #f 'jay)))) - (format-literal - (make-literal #f '= - (list (make-constant #f 'joseph) (make-constant #f 'jay))))] -} - -@defproc[(format-literals [ls (listof literal?)]) - string?]{ - Formats a list of @racket[literal]s as @racket[assertion]s for formatting @racket[prove] results. - - @examples[#:eval the-eval - (format-literals - (list - (make-literal #f 'true (list)) - (make-literal #f 'ancestor - (list (make-constant #f 'joseph) (make-constant #f 'jay))) - (make-literal #f '= - (list (make-constant #f 'joseph) (make-constant #f 'jay)))))] -} - -@defproc[(format-clause [c clause?]) - string?]{ - Formats a @racket[clause]. - - @examples[#:eval the-eval - (format-clause - (make-clause - #f (make-literal #f 'ancestor - (list (make-constant #f 'joseph) - (make-constant #f 'jay))) - (list))) - (format-clause - (make-clause - #f (make-literal - #f 'ancestor - (list (make-constant #f 'A) (make-constant #f 'B))) - (list (make-literal - #f 'parent - (list (make-constant #f 'A) (make-constant #f 'B)))))) - (format-clause - (make-clause - #f (make-literal - #f 'ancestor - (list (make-constant #f 'A) (make-constant #f 'B))) - (list (make-literal - #f 'parent - (list (make-constant #f 'A) (make-constant #f 'C))) - (make-literal - #f 'ancestor - (list (make-constant #f 'C) (make-constant #f 'B))))))] -} - -@defproc[(format-assertion [a assertion?]) - string?]{ - Formats a @racket[assertion]. - - @examples[#:eval the-eval - (format-assertion - (make-assertion - #f (make-clause - #f (make-literal #f 'ancestor - (list (make-constant #f 'joseph) - (make-constant #f 'jay))) - (list))))] -} - -@defproc[(format-retraction [r retraction?]) - string?]{ - Formats a @racket[retraction]. - - @examples[#:eval the-eval - (format-retraction - (make-retraction - #f (make-clause - #f (make-literal #f 'ancestor - (list (make-constant #f 'joseph) - (make-constant #f 'jay))) - (list))))] -} - -@defproc[(format-query [q query?]) - string?]{ - Formats a @racket[query]. - - @examples[#:eval the-eval - (format-query - (make-query - #f (make-literal #f 'ancestor - (list (make-constant #f 'joseph) - (make-constant #f 'jay)))))] -} - -@defproc[(format-statement [s statement/c]) - string?]{ - Formats a @tech{statement}. - - @examples[#:eval the-eval - (format-statement - (make-query - #f (make-literal #f 'ancestor - (list (make-constant #f 'joseph) - (make-constant #f 'jay)))))] -} - -@defproc[(format-program [p program/c]) - string?]{ - Formats a @tech{program}. - - @examples[#:eval the-eval - (format-program - (list - (make-assertion - #f (make-clause - #f (make-literal #f 'ancestor - (list (make-constant #f 'joseph) - (make-constant #f 'jay))) - (list))) - (make-query - #f (make-literal #f 'ancestor - (list (make-constant #f 'joseph) - (make-constant #f 'jay))))))] -} - -@section{Runtime System} - -This library implements the Datalog runtime system. It can be required via: - -@defmodule[datalog/runtime] - -@defthing[theory/c contract?]{ - A contract for @deftech{theories}. -} - -@defthing[immutable-theory/c contract?]{ - A contract for immutable @tech{theories}. -} - -@defthing[mutable-theory/c contract?]{ - A contract for mutable @tech{theories}. -} - -@defproc[(make-mutable-theory) - mutable-theory/c]{ - Constructs a mutable @tech{theory}. -} - -@defproc[(make-immutable-theory) - immutable-theory/c]{ - Constructs a immutable @tech{theory}. -} - -@defproc[(safe-clause? [c clause?]) - boolean?]{ - Determines if a @racket[clause] is safe. - A @racket[clause] is safe if every @racket[variable] in its head occurs in some @racket[literal] in its body. - - @examples[#:eval the-eval - (safe-clause? - (parse-clause (open-input-string "ancestor(joseph,jay)"))) - (safe-clause? - (parse-clause - (open-input-string "ancestor(A,B) :- parent(A,B)"))) - (safe-clause? - (parse-clause - (open-input-string "ancestor(A,B) :- parent(A,jay)")))] -} - -@defproc[(assume [thy immutable-theory/c] - [c safe-clause?]) - immutable-theory/c]{ - Adds @racket[c] to @racket[thy] in a persistent way. -} - -@defproc[(retract [thy immutable-theory/c] - [c clause?]) - immutable-theory/c]{ - Removes @racket[c] from @racket[thy] in a persistent way. -} - -@defproc[(assume! [thy mutable-theory/c] - [c safe-clause?]) - mutable-theory/c]{ - Adds @racket[c] to @racket[thy]. -} - -@defproc[(retract! [thy mutable-theory/c] - [c clause?]) - mutable-theory/c]{ - Removes @racket[c] from @racket[thy]. -} - -@defproc[(prove [thy theory/c] - [l literal?]) - (listof literal?)]{ - Attempts to prove @racket[l] using the @tech{theory} @racket[thy], returning all - the results of the query. - - @examples[#:eval the-eval - (format-literals - (prove - (assume - (make-immutable-theory) - (parse-clause (open-input-string "parent(joseph1,joseph2)"))) - (parse-literal - (open-input-string "parent(joseph1,joseph2)")))) - (format-literals - (prove - (retract - (assume - (make-immutable-theory) - (parse-clause - (open-input-string "parent(joseph1,joseph2)"))) - (parse-clause (open-input-string "parent(joseph1,joseph2)"))) - (parse-literal - (open-input-string "parent(joseph1,joseph2)")))) - (format-literals - (prove - (assume - (make-immutable-theory) - (parse-clause (open-input-string "parent(joseph1,joseph2)"))) - (parse-literal (open-input-string "parent(A,B)"))))] -} - -@section{Evaluation} - -This library provides facilities for evaluating Datalog. It can be required via: - -@defmodule[datalog/eval] - -@defthing[current-theory (parameter/c mutable-theory/c)]{ - The @tech{theory} used by @racket[eval-program] and @racket[eval-stmt]. -} - -@defproc[(eval-program [p program/c]) - void]{ - Evaluates @racket[p] using @racket[(current-theory)] as the @tech{theory}, printing query answers as it goes. - - This will raise a syntax error if given an @racket[assertion] of a @racket[clause] that is not a @racket[safe-clause?]. - - @examples[#:eval the-eval - (parameterize ([current-theory (make-mutable-theory)]) - (eval-program - (parse-program - (open-input-string - (string-append - "edge(a, b). edge(b, c). edge(c, d). edge(d, a)." - "path(X, Y) :- edge(X, Y)." - "path(X, Y) :- edge(X, Z), path(Z, Y)." - "path(X, Y)?"))))) - (eval-program - (parse-program - (open-input-string - "path(X, Y) :- edge(X, a).")))] -} - -@defproc[(eval-statement [s statement/c]) - (or/c void (listof literal?))]{ - Evaluates @racket[s] using @racket[(current-theory)] as the @tech{theory}. - - This will raise a syntax error if given an @racket[assertion] of a @racket[clause] that is not a @racket[safe-clause?]. - - @examples[#:eval the-eval - (parameterize ([current-theory (make-mutable-theory)]) - (eval-statement - (parse-statement - (open-input-string - "edge(a, b)."))) - (eval-statement - (parse-statement - (open-input-string - "path(X, Y) :- edge(X, Y)."))) - (eval-statement - (parse-statement - (open-input-string - "path(X, Y)?")))) - (eval-statement - (parse-statement - (open-input-string - "path(X, Y) :- edge(X, a).")))] -} - -@defproc[(eval-program/fresh [p program/c]) - immutable-theory/c]{ - Evaluates @racket[p] in a fresh @tech{theory} and returns the final @tech{theory}, printing query answers as it goes. - - This will raise a syntax error if given an @racket[assertion] of a @racket[clause] that is not a @racket[safe-clause?]. - - @examples[#:eval the-eval - (void - (eval-program/fresh - (parse-program - (open-input-string - (string-append - "edge(a, b). edge(b, c). edge(c, d). edge(d, a)." - "path(X, Y) :- edge(X, Y)." - "path(X, Y) :- edge(X, Z), path(Z, Y)." - "path(X, Y)?"))))) - (eval-program/fresh - (parse-program - (open-input-string - "path(X, Y) :- edge(X, a).")))] -} - -@index-section[] +@include-section["racket.scrbl"] @section{Acknowledgments} -This package is based on Dave Herman's @racketmodname[(planet dherman/javascript)] library and +This package is structurally based on Dave Herman's @racketmodname[(planet dherman/javascript)] library and John Ramsdell's @link["http://www.ccs.neu.edu/home/ramsdell/tools/datalog/datalog.html"]{Datalog library}. The package uses the tabled logic programming algorithm described in diff --git a/collects/datalog/scribblings/racket.scrbl b/collects/datalog/scribblings/racket.scrbl new file mode 100644 index 0000000..b3c6e0c --- /dev/null +++ b/collects/datalog/scribblings/racket.scrbl @@ -0,0 +1,638 @@ +#lang scribble/doc +@(require scribble/manual + scribble/eval + scribble/basic + scribble/bnf + (for-label racket/base + racket/contract + "../main.rkt") + "utils.rkt") + +@title{Racket Interoperability} + +@defmodule[datalog] + +@examples[#:eval the-eval + (define example-program + #<syntax]. + + Equivalent to + @racketblock[ + (or/c syntax? + false/c + (list/c any/c + (or/c exact-positive-integer? #f) + (or/c exact-nonnegative-integer? #f) + (or/c exact-nonnegative-integer? #f) + (or/c exact-positive-integer? #f))) + ] +} + +@defthing[datum/c contract?]{ + Contract for @deftech{datum}s. + Equivalent to @racket[(or/c string? symbol?)]. +} + +@defproc[(datum-equal? [d1 datum/c] [d2 datum/c]) + boolean?]{ + Equivalent to @racket[(equal? d1 d2)]. + + @examples[#:eval the-eval + (datum-equal? 'sym1 'sym2) + (datum-equal? 'sym1 'sym1) + (datum-equal? "str1" "str2") + (datum-equal? "str1" "str1")] +} + +@defstruct[variable ([srcloc srcloc/c] + [sym symbol?])]{ + A logic variable in Datalog. + (This structure does not enforce the requirements for what characters variables can contain, so if you print one out, + it might not be parseable, but it will be executeable.) +} + +@defproc[(variable-equal? [v1 variable?] [v2 variable?]) + boolean?]{ + Equivalent to @racket[(equal? v1 v2)] modulo source location. + + @examples[#:eval the-eval + (variable-equal? (make-variable #f 'sym) + (make-variable #'sym 'sym)) + (variable-equal? (make-variable #f 'sym1) + (make-variable #f 'sym2))] +} + +@defstruct[constant ([srcloc srcloc/c] + [datum datum/c])]{ + A constant in Datalog. + (This structure does not enforce the requirements for what characters constants can contain, so if you print one out, + it might not be parseable, but it will be executeable.) +} + +@defproc[(constant-equal? [c1 constant?] [c2 constant?]) + boolean?]{ + Equivalent to @racket[(equal? c1 c2)] modulo source location. + + @examples[#:eval the-eval + (constant-equal? (make-constant #f 'sym) + (make-constant #'sym 'sym)) + (constant-equal? (make-constant #f 'sym) + (make-constant #f "str"))] +} + +@defthing[term/c contract?]{ + Contract for @deftech{term}s. Equivalent to @racket[(or/c variable? constant?)]. +} + +@defproc[(term-equal? [t1 term/c] [t2 term/c]) + boolean?]{ + Equivalent to @racket[(equal? t1 t2)] modulo source location. + + @examples[#:eval the-eval + (term-equal? (make-constant #f 'sym) (make-constant #'sym 'sym)) + (term-equal? (make-constant #f 'sym) (make-constant #f "str"))] +} + +@defstruct[literal ([srcloc srcloc/c] + [predicate datum/c] + [terms (listof term/c)])]{ + A literal in Datalog. +} + +@defproc[(literal-equal? [l1 literal?] [l2 literal?]) + boolean?]{ + Equivalent to @racket[(equal? l1 l2)] modulo source location. + + @examples[#:eval the-eval + (literal-equal? (make-literal #f 'ancestor (list)) + (make-literal #'ancestor 'ancestor (list))) + (literal-equal? (make-literal #f 'ancestor (list)) + (make-literal #f 'parent (list))) + (literal-equal? (make-literal #f 'ancestor (list)) + (make-literal #f 'ancestor + (list (make-constant #f 'jack))))] +} + +@defstruct[clause ([srcloc srcloc/c] + [head literal?] + [body (listof literal?)])]{ + A Datalog clause. +} + +@defproc[(clause-equal? [c1 clause?] [c2 clause?]) + boolean?]{ + Equivalent to @racket[(equal? c1 c2)] modulo source location. + + @examples[#:eval the-eval + (clause-equal? + (make-clause #f (make-literal #f 'ancestor (list)) (list)) + (make-clause #'clause + (make-literal #f 'ancestor (list)) (list))) + (clause-equal? + (make-clause #f (make-literal #f 'ancestor (list)) (list)) + (make-clause #f (make-literal #f 'parent (list)) (list)))] +} + +@defstruct[assertion ([srcloc srcloc/c] + [clause clause?])]{ + A Datalog assertion. +} + +@defstruct[retraction ([srcloc srcloc/c] + [clause clause?])]{ + A Datalog retraction. +} + +@defstruct[query ([srcloc srcloc/c] + [clause clause?])]{ + A Datalog query. +} + +@defthing[statement/c contract?]{ + Contract for @deftech{statement}s. + Equivalent to @racket[(or/c assertion? retraction? query?)]. +} + +@defthing[program/c contract?]{ + Contract for @deftech{program}s. + Equivalent to @racket[(listof statement/c)]. +} + +@section{Datalog Parsing} + +This library provides facilities for parsing Datalog source. It can be required via: + +@defmodule[datalog/parse] + +@defproc[(parse-literal [ip input-port?]) + literal?]{ + Parses a @racket[literal] from @racket[ip]. + + @examples[#:eval the-eval + (parse-literal (open-input-string "parent(john,douglas)")) + (parse-literal (open-input-string "zero-arity-literal")) + (parse-literal (open-input-string "\"=\"(3,3)")) + (parse-literal + (open-input-string "\"\"(-0-0-0,&&&,***,\"\00\")")) + (parse-literal (open-input-string "3 = 3"))] +} + +@defproc[(parse-clause [ip input-port?]) + clause?]{ + Parses a @racket[clause] from @racket[ip]. + + @examples[#:eval the-eval + (parse-clause + (open-input-string "parent(john, douglas)")) + (parse-clause + (open-input-string "ancestor(A, B) :- parent(A, B)")) + (parse-clause + (open-input-string + (string-append "ancestor(A, B) :- parent(A, C)," + "ancestor(C, B)")))] +} + +@defproc[(parse-statement [ip input-port?]) + statement/c]{ + Parses a @tech{statement} from @racket[ip]. + + @examples[#:eval the-eval + (parse-statement + (open-input-string "parent(john, douglas).")) + (parse-statement + (open-input-string "parent(john, douglas)~")) + (parse-statement + (open-input-string "parent(john, douglas)?"))] +} + +@defproc[(parse-program [ip input-port?]) + program/c]{ + Parses a @tech{program} from @racket[ip]. + + @examples[#:eval the-eval + (parse-program + (open-input-string + (string-append + "edge(a, b). edge(b, c)." + "edge(c, d). edge(d, a)." + "path(X, Y) :- edge(X, Y)." + "path(X, Y) :- edge(X, Z), path(Z, Y)." + "path(X, Y)?")))] +} + +@section{Parenthetical Datalog Parsing} + +This package recognizes an alternative, Scheme-like front-end syntax for Datalog. It can be required via: + +@defmodule[datalog/sexp] + +@defproc[(stx->term [stx syntax?]) + term/c]{ + Parses @racket[stx] as a @tech{term}. +} +@defproc[(stx->literal [stx syntax?]) + literal?]{ + Parses @racket[stx] as a @racket[literal]. +} +@defproc[(stx->clause [stx syntax?]) + clause?]{ + Parses @racket[stx] as a @racket[clause]. +} +@defproc[(stx->statement [stx syntax?]) + statement/c]{ + Parses @racket[stx] as a @tech{statement}. +} +@defproc[(stx->program [stx syntax?]) + program/c]{ + Parses @racket[stx] as a @tech{program}. +} + +@defproc[(sexp->term [sexp sexpr?]) term/c]{@racket[stx->term] composed with @racket[datum->syntax].} +@defproc[(sexp->literal [sexp sexpr?]) literal?]{@racket[stx->literal] composed with @racket[datum->syntax].} +@defproc[(sexp->clause [sexp sexpr?]) clause?]{@racket[stx->clause] composed with @racket[datum->syntax].} +@defproc[(sexp->statement [sexp sexpr?]) statement/c]{@racket[stx->statement] composed with @racket[datum->syntax].} +@defproc[(sexp->program [sexp sexpr?]) program/c]{@racket[stx->program] composed with @racket[datum->syntax].} + +@section{Pretty-Printing} + +This library provides facilities for pretty-printing Datalog source. It can be required via: + +@defmodule[datalog/pretty] + +@defproc[(format-datum [d datum/c]) + string?]{ + Formats a @tech{datum}. + + @examples[#:eval the-eval + (format-datum 'sym) + (format-datum "str")] +} + +@defproc[(format-variable [v variable?]) + string?]{ + Formats a @racket[variable]. + + @examples[#:eval the-eval + (format-variable (make-variable #f 'Ancestor))] +} + +@defproc[(format-constant [c constant?]) + string?]{ + Formats a @racket[constant]. + + @examples[#:eval the-eval + (format-constant (make-constant #f 'joseph)) + (format-constant (make-constant #f "whom"))] +} + +@defproc[(format-term [t term/c]) + string?]{ + Formats a @tech{term}. + + @examples[#:eval the-eval + (format-term (make-variable #f 'Ancestor)) + (format-term (make-constant #f 'joseph)) + (format-term (make-constant #f "whom"))] +} + +@defproc[(format-literal [l literal?]) + string?]{ + Formats a @racket[literal]. + + @examples[#:eval the-eval + (format-literal (make-literal #f 'true (list))) + (format-literal + (make-literal #f 'ancestor + (list (make-variable #f 'A) (make-constant #f 'jay)))) + (format-literal + (make-literal #f '= + (list (make-constant #f 'joseph) (make-constant #f 'jay))))] +} + +@defproc[(format-literals [ls (listof literal?)]) + string?]{ + Formats a list of @racket[literal]s as @racket[assertion]s for formatting @racket[prove] results. + + @examples[#:eval the-eval + (format-literals + (list + (make-literal #f 'true (list)) + (make-literal #f 'ancestor + (list (make-constant #f 'joseph) (make-constant #f 'jay))) + (make-literal #f '= + (list (make-constant #f 'joseph) (make-constant #f 'jay)))))] +} + +@defproc[(format-clause [c clause?]) + string?]{ + Formats a @racket[clause]. + + @examples[#:eval the-eval + (format-clause + (make-clause + #f (make-literal #f 'ancestor + (list (make-constant #f 'joseph) + (make-constant #f 'jay))) + (list))) + (format-clause + (make-clause + #f (make-literal + #f 'ancestor + (list (make-constant #f 'A) (make-constant #f 'B))) + (list (make-literal + #f 'parent + (list (make-constant #f 'A) (make-constant #f 'B)))))) + (format-clause + (make-clause + #f (make-literal + #f 'ancestor + (list (make-constant #f 'A) (make-constant #f 'B))) + (list (make-literal + #f 'parent + (list (make-constant #f 'A) (make-constant #f 'C))) + (make-literal + #f 'ancestor + (list (make-constant #f 'C) (make-constant #f 'B))))))] +} + +@defproc[(format-assertion [a assertion?]) + string?]{ + Formats a @racket[assertion]. + + @examples[#:eval the-eval + (format-assertion + (make-assertion + #f (make-clause + #f (make-literal #f 'ancestor + (list (make-constant #f 'joseph) + (make-constant #f 'jay))) + (list))))] +} + +@defproc[(format-retraction [r retraction?]) + string?]{ + Formats a @racket[retraction]. + + @examples[#:eval the-eval + (format-retraction + (make-retraction + #f (make-clause + #f (make-literal #f 'ancestor + (list (make-constant #f 'joseph) + (make-constant #f 'jay))) + (list))))] +} + +@defproc[(format-query [q query?]) + string?]{ + Formats a @racket[query]. + + @examples[#:eval the-eval + (format-query + (make-query + #f (make-literal #f 'ancestor + (list (make-constant #f 'joseph) + (make-constant #f 'jay)))))] +} + +@defproc[(format-statement [s statement/c]) + string?]{ + Formats a @tech{statement}. + + @examples[#:eval the-eval + (format-statement + (make-query + #f (make-literal #f 'ancestor + (list (make-constant #f 'joseph) + (make-constant #f 'jay)))))] +} + +@defproc[(format-program [p program/c]) + string?]{ + Formats a @tech{program}. + + @examples[#:eval the-eval + (format-program + (list + (make-assertion + #f (make-clause + #f (make-literal #f 'ancestor + (list (make-constant #f 'joseph) + (make-constant #f 'jay))) + (list))) + (make-query + #f (make-literal #f 'ancestor + (list (make-constant #f 'joseph) + (make-constant #f 'jay))))))] +} + +@section{Runtime System} + +This library implements the Datalog runtime system. It can be required via: + +@defmodule[datalog/runtime] + +@defthing[theory/c contract?]{ + A contract for @deftech{theories}. +} + +@defthing[immutable-theory/c contract?]{ + A contract for immutable @tech{theories}. +} + +@defthing[mutable-theory/c contract?]{ + A contract for mutable @tech{theories}. +} + +@defproc[(make-mutable-theory) + mutable-theory/c]{ + Constructs a mutable @tech{theory}. +} + +@defproc[(make-immutable-theory) + immutable-theory/c]{ + Constructs a immutable @tech{theory}. +} + +@defproc[(safe-clause? [c clause?]) + boolean?]{ + Determines if a @racket[clause] is safe. + A @racket[clause] is safe if every @racket[variable] in its head occurs in some @racket[literal] in its body. + + @examples[#:eval the-eval + (safe-clause? + (parse-clause (open-input-string "ancestor(joseph,jay)"))) + (safe-clause? + (parse-clause + (open-input-string "ancestor(A,B) :- parent(A,B)"))) + (safe-clause? + (parse-clause + (open-input-string "ancestor(A,B) :- parent(A,jay)")))] +} + +@defproc[(assume [thy immutable-theory/c] + [c safe-clause?]) + immutable-theory/c]{ + Adds @racket[c] to @racket[thy] in a persistent way. +} + +@defproc[(retract [thy immutable-theory/c] + [c clause?]) + immutable-theory/c]{ + Removes @racket[c] from @racket[thy] in a persistent way. +} + +@defproc[(assume! [thy mutable-theory/c] + [c safe-clause?]) + mutable-theory/c]{ + Adds @racket[c] to @racket[thy]. +} + +@defproc[(retract! [thy mutable-theory/c] + [c clause?]) + mutable-theory/c]{ + Removes @racket[c] from @racket[thy]. +} + +@defproc[(prove [thy theory/c] + [l literal?]) + (listof literal?)]{ + Attempts to prove @racket[l] using the @tech{theory} @racket[thy], returning all + the results of the query. + + @examples[#:eval the-eval + (format-literals + (prove + (assume + (make-immutable-theory) + (parse-clause (open-input-string "parent(joseph1,joseph2)"))) + (parse-literal + (open-input-string "parent(joseph1,joseph2)")))) + (format-literals + (prove + (retract + (assume + (make-immutable-theory) + (parse-clause + (open-input-string "parent(joseph1,joseph2)"))) + (parse-clause (open-input-string "parent(joseph1,joseph2)"))) + (parse-literal + (open-input-string "parent(joseph1,joseph2)")))) + (format-literals + (prove + (assume + (make-immutable-theory) + (parse-clause (open-input-string "parent(joseph1,joseph2)"))) + (parse-literal (open-input-string "parent(A,B)"))))] +} + +@section{Evaluation} + +This library provides facilities for evaluating Datalog. It can be required via: + +@defmodule[datalog/eval] + +@defthing[current-theory (parameter/c mutable-theory/c)]{ + The @tech{theory} used by @racket[eval-program] and @racket[eval-stmt]. +} + +@defproc[(eval-program [p program/c]) + void]{ + Evaluates @racket[p] using @racket[(current-theory)] as the @tech{theory}, printing query answers as it goes. + + This will raise a syntax error if given an @racket[assertion] of a @racket[clause] that is not a @racket[safe-clause?]. + + @examples[#:eval the-eval + (parameterize ([current-theory (make-mutable-theory)]) + (eval-program + (parse-program + (open-input-string + (string-append + "edge(a, b). edge(b, c). edge(c, d). edge(d, a)." + "path(X, Y) :- edge(X, Y)." + "path(X, Y) :- edge(X, Z), path(Z, Y)." + "path(X, Y)?"))))) + (eval-program + (parse-program + (open-input-string + "path(X, Y) :- edge(X, a).")))] +} + +@defproc[(eval-statement [s statement/c]) + (or/c void (listof literal?))]{ + Evaluates @racket[s] using @racket[(current-theory)] as the @tech{theory}. + + This will raise a syntax error if given an @racket[assertion] of a @racket[clause] that is not a @racket[safe-clause?]. + + @examples[#:eval the-eval + (parameterize ([current-theory (make-mutable-theory)]) + (eval-statement + (parse-statement + (open-input-string + "edge(a, b)."))) + (eval-statement + (parse-statement + (open-input-string + "path(X, Y) :- edge(X, Y)."))) + (eval-statement + (parse-statement + (open-input-string + "path(X, Y)?")))) + (eval-statement + (parse-statement + (open-input-string + "path(X, Y) :- edge(X, a).")))] +} + +@defproc[(eval-program/fresh [p program/c]) + immutable-theory/c]{ + Evaluates @racket[p] in a fresh @tech{theory} and returns the final @tech{theory}, printing query answers as it goes. + + This will raise a syntax error if given an @racket[assertion] of a @racket[clause] that is not a @racket[safe-clause?]. + + @examples[#:eval the-eval + (void + (eval-program/fresh + (parse-program + (open-input-string + (string-append + "edge(a, b). edge(b, c). edge(c, d). edge(d, a)." + "path(X, Y) :- edge(X, Y)." + "path(X, Y) :- edge(X, Z), path(Z, Y)." + "path(X, Y)?"))))) + (eval-program/fresh + (parse-program + (open-input-string + "path(X, Y) :- edge(X, a).")))] +} \ No newline at end of file diff --git a/collects/datalog/scribblings/tutorial.scrbl b/collects/datalog/scribblings/tutorial.scrbl new file mode 100644 index 0000000..0bc80eb --- /dev/null +++ b/collects/datalog/scribblings/tutorial.scrbl @@ -0,0 +1,106 @@ +#lang scribble/doc +@(require scribble/manual + scribble/eval + scribble/basic + scribble/bnf + (for-label racket/base + racket/contract + "../main.rkt") + "utils.rkt") + +@title{Tutorial} + +Start DrScheme and choose the @tt{Datalog} language from DrScheme's +@tt{Language} menu under @tt{Experimental Languages}. Click @onscreen{Run}, then +click in the REPL. + +@racketinput[] + +@tech{Facts} are stored in tables. If the name of the table is @litchar["parent"], and +@litchar["john"] is the parent of @litchar["douglas"], store the fact in the database with +this: + +@racketinput[#,(tt "parent(john, douglas).")] + +Each item in the parenthesized list following the name of the table is called a @tech{term}. +A term can be either a logical @racket[variable] or a @racket[constant]. +Thus far, all the terms shown have been constant terms. + +A query can be used to see if a particular row is in a table. Type this to see if @litchar["john"] +is the parent of @litchar["douglas"]: + +@racketinput[#,(tt "parent(john, douglas)?")] +@racketblock[#,(racketresultfont (tt "parent(john, douglas)."))] + +Type this to see if @litchar["john"] is the parent of @litchar["ebbon"]: + +@racketinput[#,(tt "parent(john, ebbon)?")] + +The query produced no results because @litchar["john"] is not the parent of @litchar["ebbon"]. Let's add more rows. + +@racketinput[#,(tt "parent(bob, john).")] +@racketinput[#,(tt "parent(ebbon, bob).")] + +Type the following to list all rows in the @litchar["parent"] table: + +@racketinput[#,(tt "parent(A, B)?")] +@racketblock[#,(racketresultfont (tt "parent(john, douglas)."))] +@racketblock[#,(racketresultfont (tt "parent(bob, john)."))] +@racketblock[#,(racketresultfont (tt "parent(ebbon, bob)."))] + +Type the following to list all the children of @litchar["john"]: + +@racketinput[#,(tt "parent(john, B)?")] +@racketblock[#,(racketresultfont (tt "parent(john, douglas)."))] + +A term that begins with a capital letter is a logical variable.When producing a set of answers, the +Datalog interpreter lists all rows that match the query when each variable in the query is substituted +for a constant. The following example produces no answers, as there are no substitutions for the variable +@litchar["A"] that produce a fact in the database. This is because no one is the parent of oneself. + +@racketinput[#,(tt "parent(A, A)?")] + +A deductive database can use rules of inference to derive new facts. Consider the following rule: + +@racketinput[#,(tt "ancestor(A, B) :- parent(A, B).")] + +The rule says that if A is the parent of B, then A is an ancestor of B. +The other rule defining an ancestor says that if A is the parent of C, +C is an ancestor of B, then A is an ancestor of B. + +@racketinput[#,(tt "ancestor(A, B) :-") + #,(tt " parent(A, C),") + #,(tt " ancestor(C, B).")] + +In the interpreter, DrScheme knows that the clause is not complete, so by pressing Return, it doesn't interpret the line. + +Rules are used to answer queries just as is done for facts. + +@racketinput[#,(tt "ancestor(A, B)?")] +@racketblock[#,(racketresultfont (tt "ancestor(ebbon, bob)."))] +@racketblock[#,(racketresultfont (tt "ancestor(bob, john)."))] +@racketblock[#,(racketresultfont (tt "ancestor(john, douglas)."))] +@racketblock[#,(racketresultfont (tt "ancestor(bob, douglas)."))] +@racketblock[#,(racketresultfont (tt "ancestor(ebbon, john)."))] +@racketblock[#,(racketresultfont (tt "ancestor(ebbon, douglas)."))] +@racketinput[#,(tt "ancestor(X,john)?")] +@racketblock[#,(racketresultfont (tt "ancestor(bob, john)."))] +@racketblock[#,(racketresultfont (tt "ancestor(ebbon, john)."))] + +A fact or a rule can be retracted from the database using tilde syntax: + +@racketinput[#,(tt "parent(bob, john)~")] +@racketinput[#,(tt "parent(A, B)?")] +@racketblock[#,(racketresultfont (tt "parent(john, douglas)."))] +@racketblock[#,(racketresultfont (tt "parent(ebbon, bob)."))] +@racketinput[#,(tt "ancestor(A, B)?")] +@racketblock[#,(racketresultfont (tt "ancestor(ebbon, bob)."))] +@racketblock[#,(racketresultfont (tt "ancestor(john, douglas)."))] + +Unlike Prolog, the order in which clauses are asserted is irrelevant. All queries terminate, and every possible answer is derived. + +@racketinput[#,(tt "q(X) :- p(X).")] +@racketinput[#,(tt "q(a).")] +@racketinput[#,(tt "p(X) :- q(X).")] +@racketinput[#,(tt "q(X)?")] +@racketblock[#,(racketresultfont (tt "q(a)."))] From 042a0a5dbb774ed76547f929ff68b4f58f11b16b Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Fri, 25 Jun 2010 16:16:55 -0600 Subject: [PATCH 11/28] Paren datalog original commit: c1e7bf62f724160796c610028d421861f61bfad1 --- collects/datalog/eval.rkt | 13 ++-- collects/datalog/scribblings/racket.scrbl | 2 +- collects/datalog/sexp/lang.rkt | 76 +++++++++++++++++++++++ collects/datalog/sexp/lang/reader.rkt | 2 + 4 files changed, 87 insertions(+), 6 deletions(-) create mode 100644 collects/datalog/sexp/lang.rkt create mode 100644 collects/datalog/sexp/lang/reader.rkt diff --git a/collects/datalog/eval.rkt b/collects/datalog/eval.rkt index 38de442..82bf6b3 100644 --- a/collects/datalog/eval.rkt +++ b/collects/datalog/eval.rkt @@ -19,11 +19,13 @@ (format-literals ls))) (define (eval-program p) - (for-each (lambda (s) - (define v (eval-statement s)) - (unless (void? v) - (print-literals v))) - p)) + (for-each eval-top-level-statement p)) + +(define (eval-top-level-statement s) + (define v (eval-statement s)) + (unless (void? v) + (print-literals v))) + (define (eval-statement s) (cond [(assertion? s) @@ -53,5 +55,6 @@ (provide/contract [current-theory (parameter/c mutable-theory/c)] [eval-program (program/c . -> . void)] + [eval-top-level-statement (statement/c . -> . void)] [eval-statement (statement/c . -> . (or/c void (listof literal?)))] [eval-program/fresh (program/c . -> . immutable-theory/c)]) \ No newline at end of file diff --git a/collects/datalog/scribblings/racket.scrbl b/collects/datalog/scribblings/racket.scrbl index b3c6e0c..b301117 100644 --- a/collects/datalog/scribblings/racket.scrbl +++ b/collects/datalog/scribblings/racket.scrbl @@ -175,7 +175,7 @@ This library provides the structures that represent Datalog syntax. It can be re } @defstruct[query ([srcloc srcloc/c] - [clause clause?])]{ + [literal literal?])]{ A Datalog query. } diff --git a/collects/datalog/sexp/lang.rkt b/collects/datalog/sexp/lang.rkt new file mode 100644 index 0000000..d4433c9 --- /dev/null +++ b/collects/datalog/sexp/lang.rkt @@ -0,0 +1,76 @@ +#lang racket +(require (for-syntax syntax/parse) + "../eval.rkt" + "../ast.rkt") + +(define-syntax (top stx) + (syntax-parse + stx + [(_ . sym:id) + (quasisyntax/loc stx + (constant #'#,stx 'sym))])) + +(define-syntax (unquote stx) + (syntax-parse + stx + [(_ sym:id) + (quasisyntax/loc stx + (variable #'#,stx 'sym))])) + +(define-syntax (datum stx) + (syntax-parse + stx + [(_ . sym:str) + (quasisyntax/loc stx + (constant #'#,stx 'sym))])) + +(define-syntax (->literal stx) + (syntax-parse + stx + [(_ sym:id) + (quasisyntax/loc stx + (literal #'#,stx 'sym empty))] + [(_ (sym:id e ...)) + (quasisyntax/loc stx + (literal #'#,stx 'sym (list e ...)))])) + +(define-syntax (->simple-clause stx) + (syntax-case stx () + [(_ e) + (quasisyntax/loc stx + (clause #'#,stx (->literal e) empty))])) + +(define-syntax (:- stx) + (syntax-case stx () + [(_ head body ...) + (quasisyntax/loc stx + (eval-top-level-statement + (assertion #'#,stx + (clause #'#,stx (->literal head) + (list (->literal body) ...)))))])) + +(define-syntax-rule (define-paren-stx op struct) + (define-syntax (op stx) + (syntax-case stx () + [(_ c) + (quasisyntax/loc stx + (eval-top-level-statement (struct #'#,stx (->simple-clause c))))]))) + +(define-paren-stx ! assertion) +(define-paren-stx ~ retraction) + +(define-syntax (? stx) + (syntax-case stx () + [(_ c) + (quasisyntax/loc stx + (eval-top-level-statement (query #'#,stx (->literal c))))])) + +(provide (rename-out [top #%top] + [datum #%datum] + #;[module-begin #%module-begin] + #;[top-interaction #%top-interaction]) + + #%module-begin + ! ~ ? + :- + unquote) \ No newline at end of file diff --git a/collects/datalog/sexp/lang/reader.rkt b/collects/datalog/sexp/lang/reader.rkt new file mode 100644 index 0000000..546cb06 --- /dev/null +++ b/collects/datalog/sexp/lang/reader.rkt @@ -0,0 +1,2 @@ +(module reader syntax/module-reader + #:language 'datalog/sexp/lang) \ No newline at end of file From fbeb110aff7773374a8ce43f484272d51702ea4d Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Fri, 25 Jun 2010 17:07:53 -0600 Subject: [PATCH 12/28] Datalog docs original commit: e8ef7dcaa5b9e6d93e801fa149214b73d2d80377 --- collects/datalog/scribblings/datalog.scrbl | 101 ++++++++++++--------- collects/datalog/scribblings/racket.scrbl | 9 ++ collects/datalog/sexp/lang.rkt | 43 ++++++--- 3 files changed, 97 insertions(+), 56 deletions(-) diff --git a/collects/datalog/scribblings/datalog.scrbl b/collects/datalog/scribblings/datalog.scrbl index a0973a0..415929e 100644 --- a/collects/datalog/scribblings/datalog.scrbl +++ b/collects/datalog/scribblings/datalog.scrbl @@ -3,18 +3,21 @@ scribble/eval scribble/basic scribble/bnf - (for-label racket/base - racket/contract - "../main.rkt") "utils.rkt") @title[#:tag "top"]{@bold{Datalog}: Deductive database programming} @author[(author+email "Jay McCarthy" "jay@racket-lang.org")] -This package contains a lightweight deductive database system. Queries and database updates are expressed -using @link["http://en.wikipedia.org/wiki/Datalog"]{Datalog}---a declarative logic language in which each +@link["http://en.wikipedia.org/wiki/Datalog"]{Datalog} is +@itemize[ + @item{a declarative logic language in which each formula is a function-free Horn clause, and every variable -in the head of a clause must appear in the body of the clause. The use of Datalog syntax and an implementation based +in the head of a clause must appear in the body of the clause.} + @item{a lightweight deductive database system where queries and database updates are expressed + in the logic language.} +] + +The use of Datalog syntax and an implementation based on tabling intermediate results ensures that all queries terminate. @table-of-contents[] @@ -23,10 +26,6 @@ on tabling intermediate results ensures that all queries terminate. @defmodulelang[datalog] -XXX Progress - -@subsection{Datalog Syntax} - In Datalog input, whitespace characters are ignored except when they separate adjacent tokens or when they occur in strings. Comments are also considered to be whitespace. The character @litchar["%"] introduces a comment, which extends to the next line break. Comments do not occur inside strings. @@ -70,17 +69,7 @@ END A program is a sequence of zero or more statements. A statement is an assertion, a retraction, or a query. An assertion is a clause followed by a period, and it adds the clause to the database if it is safe. A retraction is a clause followed by a tilde, and it removes the clause from -the database. A query is a literal followed by a question mark. The effect of reading a Datalog program is to modify the database as directed -by its statements, and then to return the literal designated as the query. If no query is specified, a reader returns a literal know to have no -answers. The following is a program: - -@verbatim[#:indent 4 #<simple-clause stx) - (syntax-case stx () + (syntax-case stx (:-) + [(_ (:- . r)) + (quasisyntax/loc stx + (:- . r))] [(_ e) (quasisyntax/loc stx (clause #'#,stx (->literal e) empty))])) @@ -44,10 +59,8 @@ (syntax-case stx () [(_ head body ...) (quasisyntax/loc stx - (eval-top-level-statement - (assertion #'#,stx - (clause #'#,stx (->literal head) - (list (->literal body) ...)))))])) + (clause #'#,stx (->literal head) + (list (->literal body) ...)))])) (define-syntax-rule (define-paren-stx op struct) (define-syntax (op stx) @@ -65,12 +78,14 @@ (quasisyntax/loc stx (eval-top-level-statement (query #'#,stx (->literal c))))])) +(define-syntax (= stx) + (quasisyntax/loc stx + (constant #'#,stx '=))) + (provide (rename-out [top #%top] - [datum #%datum] - #;[module-begin #%module-begin] - #;[top-interaction #%top-interaction]) - + [datum #%datum]) + #%top-interaction #%module-begin ! ~ ? - :- + :- = unquote) \ No newline at end of file From f365b561ddc3165e99505d6bcf0e3d0bd3d6a6f5 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Fri, 25 Jun 2010 22:00:42 -0600 Subject: [PATCH 13/28] Moving tests original commit: e90de7196d85efeb01f760ddfc3b711aa40f2cb3 --- collects/tests/datalog/ast.rkt | 80 ++++++++++++ collects/tests/datalog/eval.rkt | 47 ++++++++ collects/tests/datalog/examples/ancestor.rkt | 12 ++ collects/tests/datalog/examples/bidipath.rkt | 7 ++ collects/tests/datalog/examples/laps.rkt | 12 ++ collects/tests/datalog/examples/long.rkt | 8 ++ collects/tests/datalog/examples/path.rkt | 6 + collects/tests/datalog/examples/pq.rkt | 6 + collects/tests/datalog/examples/revpath.rkt | 6 + collects/tests/datalog/examples/says.rkt | 5 + collects/tests/datalog/examples/true.rkt | 3 + collects/tests/datalog/examples/tutorial.rkt | 42 +++++++ collects/tests/datalog/main.rkt | 42 +++++++ .../tests/datalog/paren-examples/ancestor.rkt | 12 ++ .../tests/datalog/paren-examples/ancestor.txt | 6 + .../tests/datalog/paren-examples/bidipath.rkt | 15 +++ .../tests/datalog/paren-examples/bidipath.txt | 17 +++ .../tests/datalog/paren-examples/laps.rkt | 13 ++ .../tests/datalog/paren-examples/laps.txt | 2 + .../tests/datalog/paren-examples/long.rkt | 8 ++ .../tests/datalog/paren-examples/long.txt | 1 + .../tests/datalog/paren-examples/path.rkt | 12 ++ .../tests/datalog/paren-examples/path.txt | 17 +++ collects/tests/datalog/paren-examples/pq.rkt | 8 ++ collects/tests/datalog/paren-examples/pq.txt | 1 + .../tests/datalog/paren-examples/revpath.rkt | 12 ++ .../tests/datalog/paren-examples/revpath.txt | 17 +++ .../tests/datalog/paren-examples/says.rkt | 7 ++ .../tests/datalog/paren-examples/says.txt | 1 + .../tests/datalog/paren-examples/true.rkt | 3 + .../tests/datalog/paren-examples/true.txt | 1 + .../tests/datalog/paren-examples/tutorial.rkt | 28 +++++ .../tests/datalog/paren-examples/tutorial.txt | 26 ++++ collects/tests/datalog/parse.rkt | 52 ++++++++ collects/tests/datalog/pretty.rkt | 49 ++++++++ collects/tests/datalog/private/env.rkt | 22 ++++ collects/tests/datalog/private/lex.rkt | 37 ++++++ collects/tests/datalog/private/subst.rkt | 114 ++++++++++++++++++ collects/tests/datalog/private/unify.rkt | 54 +++++++++ collects/tests/datalog/private/variant.rkt | 59 +++++++++ collects/tests/datalog/runtime.rkt | 53 ++++++++ collects/tests/datalog/tool/syntax-color.rkt | 37 ++++++ collects/tests/datalog/util.rkt | 12 ++ 43 files changed, 972 insertions(+) create mode 100644 collects/tests/datalog/ast.rkt create mode 100644 collects/tests/datalog/eval.rkt create mode 100644 collects/tests/datalog/examples/ancestor.rkt create mode 100644 collects/tests/datalog/examples/bidipath.rkt create mode 100644 collects/tests/datalog/examples/laps.rkt create mode 100644 collects/tests/datalog/examples/long.rkt create mode 100644 collects/tests/datalog/examples/path.rkt create mode 100644 collects/tests/datalog/examples/pq.rkt create mode 100644 collects/tests/datalog/examples/revpath.rkt create mode 100644 collects/tests/datalog/examples/says.rkt create mode 100644 collects/tests/datalog/examples/true.rkt create mode 100644 collects/tests/datalog/examples/tutorial.rkt create mode 100644 collects/tests/datalog/main.rkt create mode 100644 collects/tests/datalog/paren-examples/ancestor.rkt create mode 100644 collects/tests/datalog/paren-examples/ancestor.txt create mode 100644 collects/tests/datalog/paren-examples/bidipath.rkt create mode 100644 collects/tests/datalog/paren-examples/bidipath.txt create mode 100644 collects/tests/datalog/paren-examples/laps.rkt create mode 100644 collects/tests/datalog/paren-examples/laps.txt create mode 100644 collects/tests/datalog/paren-examples/long.rkt create mode 100644 collects/tests/datalog/paren-examples/long.txt create mode 100644 collects/tests/datalog/paren-examples/path.rkt create mode 100644 collects/tests/datalog/paren-examples/path.txt create mode 100644 collects/tests/datalog/paren-examples/pq.rkt create mode 100644 collects/tests/datalog/paren-examples/pq.txt create mode 100644 collects/tests/datalog/paren-examples/revpath.rkt create mode 100644 collects/tests/datalog/paren-examples/revpath.txt create mode 100644 collects/tests/datalog/paren-examples/says.rkt create mode 100644 collects/tests/datalog/paren-examples/says.txt create mode 100644 collects/tests/datalog/paren-examples/true.rkt create mode 100644 collects/tests/datalog/paren-examples/true.txt create mode 100644 collects/tests/datalog/paren-examples/tutorial.rkt create mode 100644 collects/tests/datalog/paren-examples/tutorial.txt create mode 100644 collects/tests/datalog/parse.rkt create mode 100644 collects/tests/datalog/pretty.rkt create mode 100644 collects/tests/datalog/private/env.rkt create mode 100644 collects/tests/datalog/private/lex.rkt create mode 100644 collects/tests/datalog/private/subst.rkt create mode 100644 collects/tests/datalog/private/unify.rkt create mode 100644 collects/tests/datalog/private/variant.rkt create mode 100644 collects/tests/datalog/runtime.rkt create mode 100644 collects/tests/datalog/tool/syntax-color.rkt create mode 100644 collects/tests/datalog/util.rkt diff --git a/collects/tests/datalog/ast.rkt b/collects/tests/datalog/ast.rkt new file mode 100644 index 0000000..ec6e6ee --- /dev/null +++ b/collects/tests/datalog/ast.rkt @@ -0,0 +1,80 @@ +#lang racket +(require rackunit + datalog/ast) + +(provide ast-tests) + +(define ast-tests + (test-suite + "ast" + + (test-suite + "datum-equal?" + (test-not-false "str/str" (datum-equal? "str" "str")) + (test-false "str/str" (datum-equal? "str1" "str2")) + (test-not-false "sym/sym" (datum-equal? 'sym1 'sym1)) + (test-false "sym/sym" (datum-equal? 'sym1 'sym2)) + (test-false "str/sym" (datum-equal? "str" 'sym)) + (test-false "sym/str" (datum-equal? 'sym "str"))) + + (test-suite + "variable-equal?" + (test-not-false "var/var" (variable-equal? (make-variable #f 'sym1) (make-variable #f 'sym1))) + (test-not-false "var/var" (variable-equal? (make-variable #f 'sym1) (make-variable #'sym1 'sym1))) + (test-false "var/var" (variable-equal? (make-variable #f 'sym1) (make-variable #f 'sym2))) + (test-false "var/var" (variable-equal? (make-variable #f 'sym1) (make-variable #'sym2 'sym2)))) + + (test-suite + "constant-equal?" + (test-not-false "sym/sym" (constant-equal? (make-constant #f 'sym1) (make-constant #f 'sym1))) + (test-not-false "sym/sym" (constant-equal? (make-constant #f 'sym1) (make-constant #'sym1 'sym1))) + (test-false "sym/sym" (constant-equal? (make-constant #f 'sym1) (make-constant #'sym1 'sym2))) + (test-not-false "str/str" (constant-equal? (make-constant #f "sym1") (make-constant #f "sym1"))) + (test-not-false "str/str" (constant-equal? (make-constant #f "sym1") (make-constant #'sym1 "sym1"))) + (test-false "str/str" (constant-equal? (make-constant #f "sym1") (make-constant #'sym1 "sym2"))) + (test-false "sym/str" (constant-equal? (make-constant #f 'sym1) (make-constant #'sym1 "sym2"))) + (test-false "str/sym" (constant-equal? (make-constant #'sym1 "sym2") (make-constant #f 'sym1)))) + + (test-suite + "term-equal?" + (test-not-false "var/var" (term-equal? (make-variable #f 'sym1) (make-variable #f 'sym1))) + (test-not-false "var/var" (term-equal? (make-variable #f 'sym1) (make-variable #'sym1 'sym1))) + (test-false "var/var" (term-equal? (make-variable #f 'sym1) (make-variable #f 'sym2))) + (test-false "var/var" (term-equal? (make-variable #f 'sym1) (make-variable #'sym2 'sym2))) + (test-not-false "sym/sym" (term-equal? (make-constant #f 'sym1) (make-constant #f 'sym1))) + (test-not-false "sym/sym" (term-equal? (make-constant #f 'sym1) (make-constant #'sym1 'sym1))) + (test-false "sym/sym" (term-equal? (make-constant #f 'sym1) (make-constant #'sym1 'sym2))) + (test-not-false "str/str" (term-equal? (make-constant #f "sym1") (make-constant #f "sym1"))) + (test-not-false "str/str" (term-equal? (make-constant #f "sym1") (make-constant #'sym1 "sym1"))) + (test-false "str/str" (term-equal? (make-constant #f "sym1") (make-constant #'sym1 "sym2"))) + (test-false "sym/str" (term-equal? (make-constant #f 'sym1) (make-constant #'sym1 "sym2"))) + (test-false "str/sym" (term-equal? (make-constant #'sym1 "sym2") (make-constant #f 'sym1))) + (test-false "con/var" (term-equal? (make-constant #'sym1 "sym2") (make-variable #f 'sym1))) + (test-false "var/con" (term-equal? (make-variable #f 'sym1) (make-constant #'sym1 "sym2")))) + + (test-suite + "literal-equal?" + (test-not-false "lit" (literal-equal? (make-literal #f 'lit1 empty) (make-literal #'lit1 'lit1 empty))) + (test-not-false "lit" (literal-equal? (make-literal #f 'lit1 (list (make-variable #f 'sym1))) + (make-literal #'lit1 'lit1 (list (make-variable #f 'sym1))))) + (test-not-false "lit" (literal-equal? (make-literal #f 'lit1 (list (make-variable #f 'sym1))) + (make-literal #'lit1 'lit1 (list (make-variable #'sym1 'sym1))))) + (test-false "lit" (literal-equal? (make-literal #f 'lit1 empty) (make-literal #'lit1 'lit2 empty))) + (test-false "lit" (literal-equal? (make-literal #f 'lit1 (list (make-variable #f 'sym1))) (make-literal #'lit1 'lit2 empty))) + (test-false "lit" (literal-equal? (make-literal #f 'lit1 (list (make-variable #f 'sym1))) + (make-literal #'lit1 'lit2 (list (make-variable #'sym1 'sym2)))))) + + (test-suite + "clause-equal?" + (test-not-false "lit" (clause-equal? (make-clause #f (make-literal #f 'lit1 empty) empty) + (make-clause #f (make-literal #f 'lit1 empty) empty))) + (test-not-false "lit" (clause-equal? (make-clause #f (make-literal #f 'lit1 empty) (list (make-literal #f 'lit1 empty))) + (make-clause #f (make-literal #f 'lit1 empty) (list (make-literal #f 'lit1 empty))))) + (test-not-false "lit" (clause-equal? (make-clause #f (make-literal #f 'lit1 empty) empty) + (make-clause #'cl1 (make-literal #f 'lit1 empty) empty))) + (test-false "lit" (clause-equal? (make-clause #f (make-literal #f 'lit1 empty) empty) + (make-clause #f (make-literal #f 'lit2 empty) empty))) + (test-false "lit" (clause-equal? (make-clause #f (make-literal #f 'lit1 empty) (list (make-literal #f 'lit1 empty))) + (make-clause #f (make-literal #f 'lit1 empty) empty))) + (test-false "lit" (clause-equal? (make-clause #f (make-literal #f 'lit1 empty) (list (make-literal #f 'lit1 empty))) + (make-clause #f (make-literal #f 'lit1 empty) (list (make-literal #f 'lit2 empty)))))))) \ No newline at end of file diff --git a/collects/tests/datalog/eval.rkt b/collects/tests/datalog/eval.rkt new file mode 100644 index 0000000..8864bd6 --- /dev/null +++ b/collects/tests/datalog/eval.rkt @@ -0,0 +1,47 @@ +#lang racket +(require rackunit + racket/runtime-path + datalog/parse + datalog/eval) + +(provide eval-tests) + +(define-runtime-path here ".") + +(define (test-examples examples-dir) + + (define (test-example t) + (define test-rkt (build-path examples-dir (format "~a.rkt" t))) + (define test-txt (build-path examples-dir (format "~a.txt" t))) + (test-equal? t + (filter (lambda (l) + (not (string=? l ""))) + (with-input-from-string + (with-output-to-string + (lambda () (dynamic-require test-rkt #f))) + port->lines)) + (filter (lambda (l) + (not (string=? l ""))) + (file->lines test-txt)) + )) + + (test-suite + (path->string examples-dir) + + (test-example "ancestor") + (test-example "bidipath") + (test-example "laps") + (test-example "long") + (test-example "path") + (test-example "pq") + (test-example "revpath") + (test-example "says") + (test-example "true") + (test-example "tutorial"))) + +(define eval-tests + (test-suite + "eval" + + (test-examples (build-path here "examples")) + (test-examples (build-path here "paren-examples")))) \ No newline at end of file diff --git a/collects/tests/datalog/examples/ancestor.rkt b/collects/tests/datalog/examples/ancestor.rkt new file mode 100644 index 0000000..f448960 --- /dev/null +++ b/collects/tests/datalog/examples/ancestor.rkt @@ -0,0 +1,12 @@ +#lang datalog +% Equality test +ancestor(A, B) :- + parent(A, B). +ancestor(A, B) :- + parent(A, C), + D = C, % Unification required + ancestor(D, B). +parent(john, douglas). +parent(bob, john). +parent(ebbon, bob). +ancestor(A, B)? \ No newline at end of file diff --git a/collects/tests/datalog/examples/bidipath.rkt b/collects/tests/datalog/examples/bidipath.rkt new file mode 100644 index 0000000..cb1393b --- /dev/null +++ b/collects/tests/datalog/examples/bidipath.rkt @@ -0,0 +1,7 @@ +#lang datalog +% path test from Chen & Warren +edge(a, b). edge(b, c). edge(c, d). edge(d, a). +path(X, Y) :- edge(X, Y). +path(X, Y) :- edge(X, Z), path(Z, Y). +path(X, Y) :- path(X, Z), edge(Z, Y). +path(X, Y)? diff --git a/collects/tests/datalog/examples/laps.rkt b/collects/tests/datalog/examples/laps.rkt new file mode 100644 index 0000000..56bac66 --- /dev/null +++ b/collects/tests/datalog/examples/laps.rkt @@ -0,0 +1,12 @@ +#lang datalog +% Laps Test +contains(ca, store, rams_couch, rams). +contains(rams, fetch, rams_couch, will). +contains(ca, fetch, Name, Watcher) :- + contains(ca, store, Name, Owner), + contains(Owner, fetch, Name, Watcher). +trusted(ca). +permit(User, Priv, Name) :- + contains(Auth, Priv, Name, User), + trusted(Auth). +permit(User, Priv, Name)? diff --git a/collects/tests/datalog/examples/long.rkt b/collects/tests/datalog/examples/long.rkt new file mode 100644 index 0000000..a8b9912 --- /dev/null +++ b/collects/tests/datalog/examples/long.rkt @@ -0,0 +1,8 @@ +#lang datalog +abcdefghi(z123456789, +z1234567890123456789, +z123456789012345678901234567890123456789, +z1234567890123456789012345678901234567890123456789012345678901234567890123456789). + +this_is_a_long_identifier_and_tests_the_scanners_concat_when_read_with_a_small_buffer. +this_is_a_long_identifier_and_tests_the_scanners_concat_when_read_with_a_small_buffer? diff --git a/collects/tests/datalog/examples/path.rkt b/collects/tests/datalog/examples/path.rkt new file mode 100644 index 0000000..694aaab --- /dev/null +++ b/collects/tests/datalog/examples/path.rkt @@ -0,0 +1,6 @@ +#lang datalog +% path test from Chen & Warren +edge(a, b). edge(b, c). edge(c, d). edge(d, a). +path(X, Y) :- edge(X, Y). +path(X, Y) :- edge(X, Z), path(Z, Y). +path(X, Y)? diff --git a/collects/tests/datalog/examples/pq.rkt b/collects/tests/datalog/examples/pq.rkt new file mode 100644 index 0000000..c5efcec --- /dev/null +++ b/collects/tests/datalog/examples/pq.rkt @@ -0,0 +1,6 @@ +#lang datalog +% p q test from Chen & Warren +q(X) :- p(X). +q(a). +p(X) :- q(X). +q(X)? diff --git a/collects/tests/datalog/examples/revpath.rkt b/collects/tests/datalog/examples/revpath.rkt new file mode 100644 index 0000000..15d8fe9 --- /dev/null +++ b/collects/tests/datalog/examples/revpath.rkt @@ -0,0 +1,6 @@ +#lang datalog +% path test from Chen & Warren +edge(a, b). edge(b, c). edge(c, d). edge(d, a). +path(X, Y) :- edge(X, Y). +path(X, Y) :- path(X, Z), edge(Z, Y). +path(X, Y)? diff --git a/collects/tests/datalog/examples/says.rkt b/collects/tests/datalog/examples/says.rkt new file mode 100644 index 0000000..5ee12bb --- /dev/null +++ b/collects/tests/datalog/examples/says.rkt @@ -0,0 +1,5 @@ +#lang datalog +tpme(tpme1). +ms(m1,'TPME',tpme1,ek,tp). +says(TPME,M) :- tpme(TPME),ms(M,'TPME',TPME,A,B). +says(A,B)? diff --git a/collects/tests/datalog/examples/true.rkt b/collects/tests/datalog/examples/true.rkt new file mode 100644 index 0000000..eed11d3 --- /dev/null +++ b/collects/tests/datalog/examples/true.rkt @@ -0,0 +1,3 @@ +#lang datalog +true. +true? diff --git a/collects/tests/datalog/examples/tutorial.rkt b/collects/tests/datalog/examples/tutorial.rkt new file mode 100644 index 0000000..5981f22 --- /dev/null +++ b/collects/tests/datalog/examples/tutorial.rkt @@ -0,0 +1,42 @@ +#lang datalog + +parent(john,douglas). +parent(john,douglas)? +% parent(john, douglas). + +parent(john,ebbon)? + +parent(bob,john). +parent(ebbon,bob). +parent(A,B)? +% parent(john, douglas). +% parent(bob, john). +% parent(ebbon, bob). + +parent(john,B)? +% parent(john, douglas). + +parent(A,A)? + +ancestor(A,B) :- parent(A,B). +ancestor(A,B) :- parent(A,C), ancestor(C, B). +ancestor(A, B)? +% ancestor(ebbon, bob). +% ancestor(bob, john). +% ancestor(john, douglas). +% ancestor(bob, douglas). +% ancestor(ebbon, john). +% ancestor(ebbon, douglas). + +ancestor(X,john)? +% ancestor(bob, john). +% ancestor(ebbon, john). + +parent(bob, john)~ +parent(A,B)? +% parent(john, douglas). +% parent(ebbon, bob). + +ancestor(A,B)? +% ancestor(john, douglas). +% ancestor(ebbon, bob). diff --git a/collects/tests/datalog/main.rkt b/collects/tests/datalog/main.rkt new file mode 100644 index 0000000..7398630 --- /dev/null +++ b/collects/tests/datalog/main.rkt @@ -0,0 +1,42 @@ +#lang racket +(require rackunit + rackunit/text-ui + "ast.rkt" + + "private/lex.rkt" + "tool/syntax-color.rkt" + "parse.rkt" + "sexp.rkt" + + "pretty.rkt" + + "private/env.rkt" + "private/subst.rkt" + "private/unify.rkt" + "private/variant.rkt" + + "runtime.rkt" + "eval.rkt" + "private/compiler.rkt") + +(run-tests + (test-suite + "Datalog" + ast-tests + + lex-tests + syntax-color-tests + parse-tests + sexp-tests + + pretty-tests + + env-tests + subst-tests + unify-tests + variant-tests + + runtime-tests + eval-tests + + compiler-tests)) \ No newline at end of file diff --git a/collects/tests/datalog/paren-examples/ancestor.rkt b/collects/tests/datalog/paren-examples/ancestor.rkt new file mode 100644 index 0000000..78e5f87 --- /dev/null +++ b/collects/tests/datalog/paren-examples/ancestor.rkt @@ -0,0 +1,12 @@ +#lang datalog/sexp +; Equality test +(! (:- (ancestor ,A ,B) + (parent ,A ,B))) +(! (:- (ancestor ,A ,B) + (parent ,A ,C) + (= D C) ; Unification required + (ancestor ,D ,B))) +(! (parent john douglas)) +(! (parent bob john)) +(! (parent ebbon bob)) +(? (ancestor ,A ,B)) diff --git a/collects/tests/datalog/paren-examples/ancestor.txt b/collects/tests/datalog/paren-examples/ancestor.txt new file mode 100644 index 0000000..27724bb --- /dev/null +++ b/collects/tests/datalog/paren-examples/ancestor.txt @@ -0,0 +1,6 @@ +ancestor(ebbon, douglas). +ancestor(ebbon, john). +ancestor(bob, douglas). +ancestor(ebbon, bob). +ancestor(bob, john). +ancestor(john, douglas). diff --git a/collects/tests/datalog/paren-examples/bidipath.rkt b/collects/tests/datalog/paren-examples/bidipath.rkt new file mode 100644 index 0000000..9582561 --- /dev/null +++ b/collects/tests/datalog/paren-examples/bidipath.rkt @@ -0,0 +1,15 @@ +#lang datalog/sexp +; path test from Chen & Warren +(! (edge a b)) +(! (edge b c)) +(! (edge c d)) +(! (edge d a)) +(! (:- (path ,X ,Y) + (edge ,X ,Y))) +(! (:- (path ,X ,Y) + (edge ,X ,Z) + (path ,Z ,Y))) +(! (:- (path ,X ,Y) + (path ,X ,Z) + (edge ,Z ,Y))) +(? (path ,X ,Y)) \ No newline at end of file diff --git a/collects/tests/datalog/paren-examples/bidipath.txt b/collects/tests/datalog/paren-examples/bidipath.txt new file mode 100644 index 0000000..6c197dd --- /dev/null +++ b/collects/tests/datalog/paren-examples/bidipath.txt @@ -0,0 +1,17 @@ +path(a, a). +path(a, d). +path(a, c). +path(a, b). +path(b, b). +path(b, a). +path(b, d). +path(b, c). +path(c, c). +path(c, b). +path(c, a). +path(c, d). +path(d, d). +path(d, c). +path(d, b). +path(d, a). + diff --git a/collects/tests/datalog/paren-examples/laps.rkt b/collects/tests/datalog/paren-examples/laps.rkt new file mode 100644 index 0000000..4bf8304 --- /dev/null +++ b/collects/tests/datalog/paren-examples/laps.rkt @@ -0,0 +1,13 @@ +#lang datalog/sexp +; Laps Test +(! (contains ca store rams_couch rams)) +(! (contains rams fetch rams_couch will)) +(! (:- (contains ca fetch ,Name ,Watcher) + (contains ca store ,Name ,Owner) + (contains ,Owner fetch ,Name ,Watcher))) +(! (trusted ca)) +(! (:- (permit ,User ,Priv ,Name) + (contains ,Auth ,Priv ,Name ,User) + (trusted ,Auth))) +(? (permit ,User ,Priv ,Name)) + diff --git a/collects/tests/datalog/paren-examples/laps.txt b/collects/tests/datalog/paren-examples/laps.txt new file mode 100644 index 0000000..d87ea5f --- /dev/null +++ b/collects/tests/datalog/paren-examples/laps.txt @@ -0,0 +1,2 @@ +permit(rams, store, rams_couch). +permit(will, fetch, rams_couch). diff --git a/collects/tests/datalog/paren-examples/long.rkt b/collects/tests/datalog/paren-examples/long.rkt new file mode 100644 index 0000000..ad6ef3d --- /dev/null +++ b/collects/tests/datalog/paren-examples/long.rkt @@ -0,0 +1,8 @@ +#lang datalog/sexp +(! (abcdefghi z123456789 + z1234567890123456789 + z123456789012345678901234567890123456789 + z1234567890123456789012345678901234567890123456789012345678901234567890123456789)) +(! this_is_a_long_identifier_and_tests_the_scanners_concat_when_read_with_a_small_buffer) +(? this_is_a_long_identifier_and_tests_the_scanners_concat_when_read_with_a_small_buffer) + diff --git a/collects/tests/datalog/paren-examples/long.txt b/collects/tests/datalog/paren-examples/long.txt new file mode 100644 index 0000000..ebf5669 --- /dev/null +++ b/collects/tests/datalog/paren-examples/long.txt @@ -0,0 +1 @@ +this_is_a_long_identifier_and_tests_the_scanners_concat_when_read_with_a_small_buffer. diff --git a/collects/tests/datalog/paren-examples/path.rkt b/collects/tests/datalog/paren-examples/path.rkt new file mode 100644 index 0000000..31de89c --- /dev/null +++ b/collects/tests/datalog/paren-examples/path.rkt @@ -0,0 +1,12 @@ +#lang datalog/sexp +; path test from Chen & Warren +(! (edge a b)) +(! (edge b c)) +(! (edge c d)) +(! (edge d a)) +(! (:- (path ,X ,Y) + (edge ,X ,Y))) +(! (:- (path ,X ,Y) + (edge ,X ,Z) + (path ,Z ,Y))) +(? (path ,X ,Y)) diff --git a/collects/tests/datalog/paren-examples/path.txt b/collects/tests/datalog/paren-examples/path.txt new file mode 100644 index 0000000..cfe9dae --- /dev/null +++ b/collects/tests/datalog/paren-examples/path.txt @@ -0,0 +1,17 @@ +path(a, a). +path(a, d). +path(a, c). +path(a, b). +path(b, a). +path(b, d). +path(b, c). +path(b, b). +path(c, a). +path(c, b). +path(c, c). +path(c, d). +path(d, b). +path(d, c). +path(d, d). +path(d, a). + diff --git a/collects/tests/datalog/paren-examples/pq.rkt b/collects/tests/datalog/paren-examples/pq.rkt new file mode 100644 index 0000000..1c08e17 --- /dev/null +++ b/collects/tests/datalog/paren-examples/pq.rkt @@ -0,0 +1,8 @@ +#lang datalog/sexp +; p q test from Chen & Warren +(! (:- (q ,X) + (p ,X))) +(! (q a)) +(! (:- (p ,X) + (q ,X))) +(? (q ,X)) diff --git a/collects/tests/datalog/paren-examples/pq.txt b/collects/tests/datalog/paren-examples/pq.txt new file mode 100644 index 0000000..7526e51 --- /dev/null +++ b/collects/tests/datalog/paren-examples/pq.txt @@ -0,0 +1 @@ +q(a). diff --git a/collects/tests/datalog/paren-examples/revpath.rkt b/collects/tests/datalog/paren-examples/revpath.rkt new file mode 100644 index 0000000..33cc238 --- /dev/null +++ b/collects/tests/datalog/paren-examples/revpath.rkt @@ -0,0 +1,12 @@ +#lang datalog/sexp +; path test from Chen & Warren +(! (edge a b)) +(! (edge b c)) +(! (edge c d)) +(! (edge d a)) +(! (:- (path ,X ,Y) + (edge ,X ,Y))) +(! (:- (path ,X ,Y) + (path ,X ,Z) + (edge ,Z ,Y))) +(? (path ,X ,Y)) \ No newline at end of file diff --git a/collects/tests/datalog/paren-examples/revpath.txt b/collects/tests/datalog/paren-examples/revpath.txt new file mode 100644 index 0000000..6c197dd --- /dev/null +++ b/collects/tests/datalog/paren-examples/revpath.txt @@ -0,0 +1,17 @@ +path(a, a). +path(a, d). +path(a, c). +path(a, b). +path(b, b). +path(b, a). +path(b, d). +path(b, c). +path(c, c). +path(c, b). +path(c, a). +path(c, d). +path(d, d). +path(d, c). +path(d, b). +path(d, a). + diff --git a/collects/tests/datalog/paren-examples/says.rkt b/collects/tests/datalog/paren-examples/says.rkt new file mode 100644 index 0000000..1c10fb0 --- /dev/null +++ b/collects/tests/datalog/paren-examples/says.rkt @@ -0,0 +1,7 @@ +#lang datalog/sexp +(! (tpme tpme1)) +(! (ms m1 "TPME" tpme1 ek tp)) +(! (:- (says ,TPME ,M) + (tpme ,TPME) + (ms ,M "TPME" ,TPME ,A ,B))) +(? (says ,A ,B)) diff --git a/collects/tests/datalog/paren-examples/says.txt b/collects/tests/datalog/paren-examples/says.txt new file mode 100644 index 0000000..473484a --- /dev/null +++ b/collects/tests/datalog/paren-examples/says.txt @@ -0,0 +1 @@ +says(tpme1, m1). diff --git a/collects/tests/datalog/paren-examples/true.rkt b/collects/tests/datalog/paren-examples/true.rkt new file mode 100644 index 0000000..18ccecb --- /dev/null +++ b/collects/tests/datalog/paren-examples/true.rkt @@ -0,0 +1,3 @@ +#lang datalog/sexp +(! true) +(? true) \ No newline at end of file diff --git a/collects/tests/datalog/paren-examples/true.txt b/collects/tests/datalog/paren-examples/true.txt new file mode 100644 index 0000000..48eb7ed --- /dev/null +++ b/collects/tests/datalog/paren-examples/true.txt @@ -0,0 +1 @@ +true. diff --git a/collects/tests/datalog/paren-examples/tutorial.rkt b/collects/tests/datalog/paren-examples/tutorial.rkt new file mode 100644 index 0000000..90e1d6c --- /dev/null +++ b/collects/tests/datalog/paren-examples/tutorial.rkt @@ -0,0 +1,28 @@ +#lang datalog/sexp +(! (parent john douglas)) +(? (parent john douglas)) + +(? (parent john ebbon)) + +(! (parent bob john)) +(! (parent ebbon bob)) +(? (parent ,A ,B)) + +(? (parent john ,B)) + +(? (parent ,A ,A)) + +(! (:- (ancestor ,A ,B) + (parent ,A ,B))) +(! (:- (ancestor ,A ,B) + (parent ,A ,C) + (ancestor ,C ,B))) +(? (ancestor ,A ,B)) + +(? (ancestor ,X john)) + +(~ (parent bob john)) + +(? (parent ,A ,B)) + +(? (ancestor ,A ,B)) diff --git a/collects/tests/datalog/paren-examples/tutorial.txt b/collects/tests/datalog/paren-examples/tutorial.txt new file mode 100644 index 0000000..629d2dc --- /dev/null +++ b/collects/tests/datalog/paren-examples/tutorial.txt @@ -0,0 +1,26 @@ +parent(john, douglas). + + +parent(john, douglas). +parent(bob, john). +parent(ebbon, bob). + +parent(john, douglas). + + +ancestor(ebbon, bob). +ancestor(bob, john). +ancestor(john, douglas). +ancestor(bob, douglas). +ancestor(ebbon, john). +ancestor(ebbon, douglas). + +ancestor(bob, john). +ancestor(ebbon, john). + +parent(john, douglas). +parent(ebbon, bob). + +ancestor(ebbon, bob). +ancestor(john, douglas). + diff --git a/collects/tests/datalog/parse.rkt b/collects/tests/datalog/parse.rkt new file mode 100644 index 0000000..db86b57 --- /dev/null +++ b/collects/tests/datalog/parse.rkt @@ -0,0 +1,52 @@ +#lang racket +(require rackunit + datalog/ast + datalog/parse + "util.rkt") + +(provide parse-tests) + +(define (test-literal-parse str res) + (test-literal str (parse-literal (open-input-string str)) res)) +(define (test-clause-parse str res) + (test-clause str (parse-clause (open-input-string str)) res)) + +(define parse-tests + (test-suite + "parse" + + (test-suite + "literal" + (test-literal-parse "parent(john, douglas)" + (make-literal #f 'parent (list (make-constant #f 'john) (make-constant #f 'douglas)))) + (test-literal-parse "1 = 2" + (make-literal #f '= (list (make-constant #f '|1|) (make-constant #f '|2|)))) + (test-literal-parse "zero-arity-literal" + (make-literal #f 'zero-arity-literal empty)) + (test-literal-parse "zero-arity-literal()" + (make-literal #f 'zero-arity-literal empty)) + (test-literal-parse "\"=\"(3,3)" + (make-literal #f "=" (list (make-constant #f '|3|) (make-constant #f '|3|)))) + (test-literal-parse "\"\"(-0-0-0,&&&,***,\"\00\")" + (make-literal #f "" (list (make-constant #f '-0-0-0) + (make-constant #f '&&&) + (make-constant #f '***) + (make-constant #f "\00"))))) + + (test-suite + "clause" + (test-clause-parse "parent(john, douglas)" + (make-clause #f (make-literal #f 'parent (list (make-constant #f 'john) (make-constant #f 'douglas))) empty)) + (test-clause-parse "ancestor(A, B) :- parent(A, B)" + (make-clause #f (make-literal #f 'ancestor (list (make-variable #f 'A) (make-variable #f 'B))) + (list (make-literal #f 'parent (list (make-variable #f 'A) (make-variable #f 'B)))))) + (test-clause-parse "ancestor(A, B) :- parent(A, C), ancestor(C, B)" + (make-clause #f (make-literal #f 'ancestor (list (make-variable #f 'A) (make-variable #f 'B))) + (list (make-literal #f 'parent (list (make-variable #f 'A) (make-variable #f 'C))) + (make-literal #f 'ancestor (list (make-variable #f 'C) (make-variable #f 'B))))))) + + (test-suite + "statement" + (test-not-false "assertion" (assertion? (parse-statement (open-input-string "parent(john, douglas).")))) + (test-not-false "retraction" (retraction? (parse-statement (open-input-string "parent(john, douglas)~")))) + (test-not-false "query" (query? (parse-statement (open-input-string "parent(john, douglas)?"))))))) \ No newline at end of file diff --git a/collects/tests/datalog/pretty.rkt b/collects/tests/datalog/pretty.rkt new file mode 100644 index 0000000..a0fe339 --- /dev/null +++ b/collects/tests/datalog/pretty.rkt @@ -0,0 +1,49 @@ +#lang racket +(require rackunit + datalog/parse + datalog/pretty) +(provide pretty-tests) + +(define pretty-tests + (test-suite + "Pretty" + + (test-equal? "program" + (format-program + (parse-program + (open-input-string #<" str tok-name tok-value) + (cons tok-name tok-value) + (cons (token-name v) (token-value v)))) + +(define lex-tests + (test-suite + "lex" + + (test-lexer "=" 'EQUAL #f) + (test-lexer "?" 'QMARK #f) + (test-lexer "~" 'TILDE #f) + (test-lexer "." 'DOT #f) + (test-lexer ")" 'RPAREN #f) + (test-lexer "," 'COMMA #f) + (test-lexer "(" 'LPAREN #f) + (test-lexer "\"\"" 'STRING "") + (test-lexer "\"foo\"" 'STRING "foo") + (test-lexer "\"\\\"\"" 'STRING "\"") + (test-lexer ":-" 'TSTILE #f) + (test-lexer "" 'EOF #f) + (test-lexer "Va1_" 'VARIABLE) + (test-lexer "val_" 'IDENTIFIER) + (test-lexer "912Kadf" 'IDENTIFIER) + (test-lexer " =" 'EQUAL #f) + (test-lexer "% 12453\n=" 'EQUAL #f) + + )) \ No newline at end of file diff --git a/collects/tests/datalog/private/subst.rkt b/collects/tests/datalog/private/subst.rkt new file mode 100644 index 0000000..2871f40 --- /dev/null +++ b/collects/tests/datalog/private/subst.rkt @@ -0,0 +1,114 @@ +#lang racket +(require rackunit + datalog/private/subst + datalog/ast + datalog/private/env) +(require/expose datalog/private/subst (subst-literal shuffle)) + +(provide subst-tests) + +(define (gensym-var? v) + (define s (variable-sym v)) + (not (eq? s (string->symbol (symbol->string s))))) + +(define subst-tests + (test-suite + "subst" + + (test-suite + "subst-term" + (test-equal? "con" + (subst-term (empty-env) (make-constant #f 'v1)) + (make-constant #f 'v1)) + (test-equal? "var def" + (subst-term (empty-env) (make-variable #f 'v1)) + (make-variable #f 'v1)) + (test-equal? "var" + (subst-term (extend (empty-env) 'v1 (make-constant #f 'v1)) (make-variable #f 'v1)) + (make-constant #f 'v1))) + + (test-suite + "subst-literal" + (test-equal? "con" + (subst-literal (empty-env) (make-literal #f 'lit (list (make-constant #f 'v1)))) + (make-literal #f 'lit (list (make-constant #f 'v1)))) + (test-equal? "var def" + (subst-literal (extend (empty-env) 'v1 (make-constant #f 'v1)) (make-literal #f 'lit (list (make-variable #f 'v1)))) + (make-literal #f 'lit (list (make-constant #f 'v1)))) + (test-equal? "var def" + (subst-literal (extend (empty-env) 'v1 (make-constant #f 'v1)) (make-literal #f 'lit (list (make-variable #f 'v1)))) + (make-literal #f 'lit (list (make-constant #f 'v1))))) + + (test-suite + "subst-clause" + (test-equal? "con" + (subst-clause (empty-env) (make-clause #f (make-literal #f 'lit (list (make-constant #f 'v1))) empty)) + (make-clause #f (make-literal #f 'lit (list (make-constant #f 'v1))) empty)) + (test-equal? "var def" + (subst-clause (extend (empty-env) 'v1 (make-constant #f 'v1)) + (make-clause #f (make-literal #f 'lit (list (make-variable #f 'v1))) empty)) + (make-clause #f (make-literal #f 'lit (list (make-constant #f 'v1))) empty)) + (test-equal? "var def" + (subst-clause (extend (empty-env) 'v1 (make-constant #f 'v1)) + (make-clause #f (make-literal #f 'lit (list (make-variable #f 'v1))) empty)) + (make-clause #f (make-literal #f 'lit (list (make-constant #f 'v1))) empty)) + + (test-equal? "con" + (subst-clause (empty-env) (make-clause #f (make-literal #f 'lit (list (make-constant #f 'v1))) + (list (make-literal #f 'lit (list (make-constant #f 'v1)))))) + (make-clause #f (make-literal #f 'lit (list (make-constant #f 'v1))) + (list (make-literal #f 'lit (list (make-constant #f 'v1)))))) + (test-equal? "var def" + (subst-clause (extend (empty-env) 'v1 (make-constant #f 'v1)) + (make-clause #f (make-literal #f 'lit (list (make-variable #f 'v1))) + (list (make-literal #f 'lit (list (make-variable #f 'v1)))))) + (make-clause #f (make-literal #f 'lit (list (make-constant #f 'v1))) + (list (make-literal #f 'lit (list (make-constant #f 'v1)))))) + (test-equal? "var def" + (subst-clause (extend (empty-env) 'v1 (make-constant #f 'v1)) + (make-clause #f (make-literal #f 'lit (list (make-variable #f 'v1))) + (list (make-literal #f 'lit (list (make-variable #f 'v1)))))) + (make-clause #f (make-literal #f 'lit (list (make-constant #f 'v1))) + (list (make-literal #f 'lit (list (make-constant #f 'v1))))))) + + (test-suite + "shuffle" + (test-equal? "con" + (shuffle (empty-env) (make-literal #f 'lit (list (make-constant #f 'v1)))) + (empty-env)) + (test-equal? "var" + (shuffle (extend (empty-env) 'v1 (make-constant #f 'k1)) (make-literal #f 'lit (list (make-variable #f 'v1)))) + (extend (empty-env) 'v1 (make-constant #f 'k1))) + (test-not-false "var" + (gensym-var? (lookup (shuffle (empty-env) + (make-literal #f 'lit (list (make-variable #f 'v1)))) + 'v1)))) + + (test-suite + "rename-literal" + (test-equal? "l" (rename-literal (make-literal #f 'lit (list (make-constant #f 'v1)))) + (make-literal #f 'lit (list (make-constant #f 'v1)))) + (test-not-false "l" + (gensym-var? + (first + (literal-terms + (rename-literal (make-literal #f 'lit (list (make-variable #f 'v1))))))))) + + (test-suite + "rename-clause" + (test-equal? "c" (rename-clause (make-clause #f (make-literal #f 'lit (list (make-constant #f 'v1))) empty)) + (make-clause #f (make-literal #f 'lit (list (make-constant #f 'v1))) empty)) + (test-not-false "c" + (gensym-var? + (first + (literal-terms + (clause-head + (rename-clause (make-clause #f (make-literal #f 'lit (list (make-variable #f 'v1))) empty))))))) + (test-not-false "c" + (gensym-var? + (first + (literal-terms + (first + (clause-body + (rename-clause (make-clause #f (make-literal #f 'lit (list (make-constant #f 'v1))) + (list (make-literal #f 'lit (list (make-variable #f 'v1))))))))))))))) \ No newline at end of file diff --git a/collects/tests/datalog/private/unify.rkt b/collects/tests/datalog/private/unify.rkt new file mode 100644 index 0000000..2ea94e6 --- /dev/null +++ b/collects/tests/datalog/private/unify.rkt @@ -0,0 +1,54 @@ +#lang racket +(require rackunit + datalog/ast + datalog/private/env + datalog/private/unify) +(require/expose datalog/private/unify (chase unify-terms)) + +(provide unify-tests) + +(define unify-tests + (test-suite + "unify" + + (test-suite + "chase" + (test-equal? "con" (chase (empty-env) (make-constant #f 'k1)) + (make-constant #f 'k1)) + (test-equal? "var" (chase (empty-env) (make-variable #f 'v1)) + (make-variable #f 'v1)) + (test-equal? "var->con" + (chase (extend (empty-env) 'v1 (make-constant #f 'k1)) (make-variable #f 'v1)) + (make-constant #f 'k1)) + (test-equal? "var->var->con" + (chase (extend (extend (empty-env) 'v2 (make-constant #f 'k1)) + 'v1 (make-variable #f 'v2)) + (make-variable #f 'v1)) + (make-constant #f 'k1))) + + (test-suite + "unify-term" + (test-equal? "con/con" (unify-term (empty-env) (make-constant #f 'k1) (make-constant #f 'k1)) + (empty-env)) + (test-false "con/con" (unify-term (empty-env) (make-constant #f 'k1) (make-constant #f 'k2))) + (test-equal? "var/con" (unify-term (empty-env) (make-variable #f 'v1) (make-constant #f 'k2)) + (extend (empty-env) 'v1 (make-constant #f 'k2))) + (test-equal? "con/var" (unify-term (empty-env) (make-constant #f 'k2) (make-variable #f 'v1)) + (extend (empty-env) 'v1 (make-constant #f 'k2))) + (test-equal? "var/var" (unify-term (empty-env) (make-variable #f 'v1) (make-variable #f 'v2)) + (extend (empty-env) 'v1 (make-variable #f 'v2)))) + + (test-suite + "unify-terms" + (test-equal? "con/con" (unify-terms (empty-env) (list (make-constant #f 'k1)) (list (make-constant #f 'k1))) + (empty-env)) + (test-false "con/con" (unify-terms (empty-env) (list (make-constant #f 'k1)) (list (make-constant #f 'k2)))) + (test-false "/con" (unify-terms (empty-env) (list) (list (make-constant #f 'k2)))) + (test-false "con/" (unify-terms (empty-env) (list (make-constant #f 'k2)) (list)))) + + (test-suite + "unify" + (test-false "lit/lit" (unify (make-literal #f 'lit1 empty) (make-literal #f 'lit2 empty))) + (test-equal? "con/con" (unify (make-literal #f 'lit1 (list (make-constant #f 'k1))) + (make-literal #f 'lit1 (list (make-constant #f 'k1)))) + (empty-env))))) \ No newline at end of file diff --git a/collects/tests/datalog/private/variant.rkt b/collects/tests/datalog/private/variant.rkt new file mode 100644 index 0000000..cd1299b --- /dev/null +++ b/collects/tests/datalog/private/variant.rkt @@ -0,0 +1,59 @@ +#lang racket +(require rackunit + datalog/ast + datalog/private/variant) +(require/expose datalog/private/variant + (variant-terms variant-term variant-var variant? term-hash mk-literal-hash)) + +(provide variant-tests) + +(define (test-not-equal? n v1 v2) + (test-case n (check-not-equal? v1 v2))) + +(define variant-tests + (test-suite + "variant" + + (test-suite + "variant?" + (test-not-false "same" (variant? (make-literal #f 'lit1 empty) (make-literal #f 'lit1 empty))) + (test-false "dif lit" (variant? (make-literal #f 'lit1 empty) (make-literal #f 'lit2 empty))) + (test-not-false "same" (variant? (make-literal #f 'lit1 (list (make-constant #f 'k1))) + (make-literal #f 'lit1 (list (make-constant #f 'k1))))) + (test-false "dif con" (variant? (make-literal #f 'lit1 (list (make-constant #f 'k1))) + (make-literal #f 'lit1 (list (make-constant #f 'k2))))) + (test-false "dif var/con" (variant? (make-literal #f 'lit1 (list (make-variable #f 'v1))) + (make-literal #f 'lit1 (list (make-constant #f 'k1))))) + (test-false "dif con/var" (variant? (make-literal #f 'lit1 (list (make-constant #f 'k1))) + (make-literal #f 'lit1 (list (make-variable #f 'v1))))) + (test-not-false "same" (variant? (make-literal #f 'lit1 (list (make-variable #f 'v1))) + (make-literal #f 'lit1 (list (make-variable #f 'v1))))) + + (test-not-false "var (dif name)" (variant? (make-literal #f 'lit1 (list (make-variable #f 'v2))) + (make-literal #f 'lit1 (list (make-variable #f 'v1)))))) + + (test-suite + "mem-literal" + (test-false "mt" (mem-literal (make-literal #f 'lit1 empty) empty)) + (test-not-false "in" (mem-literal (make-literal #f 'lit1 empty) (list (make-literal #f 'lit1 empty)))) + (test-not-false "var" (mem-literal (make-literal #f 'lit1 (list (make-variable #f 'v2))) + (list (make-literal #f 'lit1 (list (make-variable #f 'v1))))))) + + (test-suite + "term-hash" + (test-equal? "var" (term-hash (make-variable #f (gensym)) equal-hash-code) 101) + (test-equal? "con" (term-hash (make-constant #f 'v2) equal-hash-code) (equal-hash-code 'v2))) + + (local [(define literal-hash (mk-literal-hash equal-hash-code)) + (define (literal-hash-equal? l1 l2) + (equal? (literal-hash l1) (literal-hash l2)))] + (test-suite + "mk-literal-hash" + (test-not-false "same" (literal-hash-equal? (make-literal #f 'lit1 empty) (make-literal #f 'lit1 empty))) + (test-not-false "same" (literal-hash-equal? (make-literal #f 'lit1 (list (make-constant #f 'k1))) + (make-literal #f 'lit1 (list (make-constant #f 'k1))))) + (test-not-false "same" (literal-hash-equal? (make-literal #f 'lit1 (list (make-variable #f 'v1))) + (make-literal #f 'lit1 (list (make-variable #f 'v1))))) + + (test-not-false "var (dif name)" (literal-hash-equal? (make-literal #f 'lit1 (list (make-variable #f 'v2))) + (make-literal #f 'lit1 (list (make-variable #f 'v1))))))))) \ No newline at end of file diff --git a/collects/tests/datalog/runtime.rkt b/collects/tests/datalog/runtime.rkt new file mode 100644 index 0000000..202f8ff --- /dev/null +++ b/collects/tests/datalog/runtime.rkt @@ -0,0 +1,53 @@ +#lang racket +(require rackunit + datalog/parse + datalog/runtime + "util.rkt") + +(provide runtime-tests) + +(define pc (parse-clause (open-input-string "parent(john, douglas)"))) +(define pl (parse-literal (open-input-string "parent(john, douglas)"))) + +(define runtime-tests + (test-suite + "runtime" + + (test-suite + "safe-clause?" + (test-not-false "safe" (safe-clause? pc)) + (test-not-false "safe" (safe-clause? (parse-clause (open-input-string "ancestor(A, B) :- parent(A, B)")))) + (test-false "not safe" (safe-clause? (parse-clause (open-input-string "ancestor(A, B) :- parent(jay, B)")))) + (test-not-false "safe" (safe-clause? (parse-clause (open-input-string "ancestor(A, B) :- parent(A, C), ancestor(C, B)"))))) + + (test-suite + "imm simple" + (test-equal? "empty" (prove (make-immutable-theory) pl) empty) + (test-literal "ass->prov" + (first (prove (assume (make-immutable-theory) pc) pl)) + pl) + (test-equal? "ass->ret->prov" (prove (retract (assume (make-immutable-theory) pc) pc) pl) empty) + (test-equal? "ret->prov" (prove (retract (make-immutable-theory) pc) pl) empty)) + + (test-suite + "mut simple" + (test-equal? "empty" (prove (make-mutable-theory) pl) empty) + (test-literal "ass->prov" + (let ([thy (make-mutable-theory)]) + (assume! thy pc) + (first (prove thy pl))) + pl) + (test-equal? "ass->ret->prov" + (let ([thy (make-mutable-theory)]) + (assume! thy pc) + (retract! thy pc) + (prove thy pl)) + empty) + (test-equal? "ret->prov" + (let ([thy (make-mutable-theory)]) + (retract! thy pc) + (prove thy pl)) + empty)) + + )) + diff --git a/collects/tests/datalog/tool/syntax-color.rkt b/collects/tests/datalog/tool/syntax-color.rkt new file mode 100644 index 0000000..6b48bb8 --- /dev/null +++ b/collects/tests/datalog/tool/syntax-color.rkt @@ -0,0 +1,37 @@ +#lang racket +(require rackunit + datalog/tool/syntax-color) + +(provide syntax-color-tests) + +(define (test-color str key) + (define-values (lex color b start end) (get-syntax-token (open-input-string str))) + (test-equal? (format "Syntax Color: ~a: ~a" key str) color key)) + +(define syntax-color-tests + (test-suite + "syntax-color" + + (test-color " " 'whitespace) + (test-color " " 'whitespace) + (test-color "\t" 'whitespace) + (test-color "\n" 'whitespace) + (test-color "% \n" 'comment) + (test-color "% 12 31 2 6\n" 'comment) + (test-color "Var" 'symbol) + (test-color "V124_3" 'symbol) + (test-color "var" 'identifier) + (test-color "123var" 'identifier) + (test-color "(" 'parenthesis) + (test-color ")" 'parenthesis) + (test-color "=" 'parenthesis) + (test-color "?" 'parenthesis) + (test-color "~" 'parenthesis) + (test-color "." 'parenthesis) + (test-color "," 'parenthesis) + (test-color ":-" 'parenthesis) + (test-color "\"foo\"" 'string) + (test-color "\"fo\\\"o\"" 'string) + (test-color "\"fo\no\"" 'string) + (test-color "\"foo" 'error) + (test-color ":" 'error))) \ No newline at end of file diff --git a/collects/tests/datalog/util.rkt b/collects/tests/datalog/util.rkt new file mode 100644 index 0000000..581c80c --- /dev/null +++ b/collects/tests/datalog/util.rkt @@ -0,0 +1,12 @@ +#lang racket +(require rackunit + datalog/ast) + +(provide test-literal test-clause) + +(define (test-literal str l1 l2) + (test-case + str (check literal-equal? l1 l2))) +(define (test-clause str c1 c2) + (test-case + str (check clause-equal? c1 c2))) From 5287b0c6cfa91e50175ce990c6aeb0e098930335 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Fri, 25 Jun 2010 22:04:55 -0600 Subject: [PATCH 14/28] Removing old sexp library and correct docs for warning original commit: 0bda9efa9650cc5ddd73f42244e3a91f67799f66 --- collects/datalog/main.rkt | 2 -- collects/datalog/scribblings/racket.scrbl | 35 +---------------------- collects/tests/datalog/main.rkt | 6 ++-- 3 files changed, 3 insertions(+), 40 deletions(-) diff --git a/collects/datalog/main.rkt b/collects/datalog/main.rkt index 3d4186d..1876c57 100644 --- a/collects/datalog/main.rkt +++ b/collects/datalog/main.rkt @@ -1,13 +1,11 @@ #lang racket (require "ast.rkt" "parse.rkt" - "sexp.rkt" "pretty.rkt" "runtime.rkt" "eval.rkt") (provide (all-from-out "ast.rkt" "parse.rkt" - "sexp.rkt" "pretty.rkt" "runtime.rkt" "eval.rkt")) \ No newline at end of file diff --git a/collects/datalog/scribblings/racket.scrbl b/collects/datalog/scribblings/racket.scrbl index 2ade2a8..484bdd6 100644 --- a/collects/datalog/scribblings/racket.scrbl +++ b/collects/datalog/scribblings/racket.scrbl @@ -10,7 +10,7 @@ @title{Racket Interoperability} -@defmodule[datalog] +@defmodule[datalog/main] The Datalog database can be directly used by Racket programs through this API. @@ -253,39 +253,6 @@ This library provides facilities for parsing Datalog source. It can be required "path(X, Y)?")))] } -@section{Parenthetical Datalog Parsing} - -This package recognizes an alternative, Scheme-like front-end syntax for Datalog. It can be required via: - -@defmodule[datalog/sexp] - -@defproc[(stx->term [stx syntax?]) - term/c]{ - Parses @racket[stx] as a @tech{term}. -} -@defproc[(stx->literal [stx syntax?]) - literal?]{ - Parses @racket[stx] as a @racket[literal]. -} -@defproc[(stx->clause [stx syntax?]) - clause?]{ - Parses @racket[stx] as a @racket[clause]. -} -@defproc[(stx->statement [stx syntax?]) - statement/c]{ - Parses @racket[stx] as a @tech{statement}. -} -@defproc[(stx->program [stx syntax?]) - program/c]{ - Parses @racket[stx] as a @tech{program}. -} - -@defproc[(sexp->term [sexp sexpr?]) term/c]{@racket[stx->term] composed with @racket[datum->syntax].} -@defproc[(sexp->literal [sexp sexpr?]) literal?]{@racket[stx->literal] composed with @racket[datum->syntax].} -@defproc[(sexp->clause [sexp sexpr?]) clause?]{@racket[stx->clause] composed with @racket[datum->syntax].} -@defproc[(sexp->statement [sexp sexpr?]) statement/c]{@racket[stx->statement] composed with @racket[datum->syntax].} -@defproc[(sexp->program [sexp sexpr?]) program/c]{@racket[stx->program] composed with @racket[datum->syntax].} - @section{Pretty-Printing} This library provides facilities for pretty-printing Datalog source. It can be required via: diff --git a/collects/tests/datalog/main.rkt b/collects/tests/datalog/main.rkt index 7398630..2f5b15b 100644 --- a/collects/tests/datalog/main.rkt +++ b/collects/tests/datalog/main.rkt @@ -5,8 +5,7 @@ "private/lex.rkt" "tool/syntax-color.rkt" - "parse.rkt" - "sexp.rkt" + "parse.rkt" "pretty.rkt" @@ -26,8 +25,7 @@ lex-tests syntax-color-tests - parse-tests - sexp-tests + parse-tests pretty-tests From 1e0f7514bcb12d08b15b0790827a9104afb8e66f Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Fri, 25 Jun 2010 22:36:03 -0600 Subject: [PATCH 15/28] Using current-read-interaction and renabling adapted tutorial original commit: 8afc06c09679827189aa8f5918cb914f6a02d731 --- collects/datalog/lang/reader.rkt | 18 ++++++++++++++++-- collects/datalog/parse.rkt | 1 + collects/datalog/scribblings/datalog.scrbl | 6 +++++- collects/datalog/scribblings/racket.scrbl | 2 ++ collects/datalog/scribblings/tutorial.scrbl | 10 ++++++---- 5 files changed, 30 insertions(+), 7 deletions(-) diff --git a/collects/datalog/lang/reader.rkt b/collects/datalog/lang/reader.rkt index 701c0c8..7394896 100644 --- a/collects/datalog/lang/reader.rkt +++ b/collects/datalog/lang/reader.rkt @@ -11,8 +11,22 @@ ; XXX Should have different comment character key (case key [(drracket:submit-predicate) - (dynamic-require `datalog/tool/submit 'repl-submit?)] + repl-submit?] [(color-lexer) (dynamic-require `datalog/tool/syntax-color 'get-syntax-token)] [else (default key defval)])) - (require "../parse.rkt")) \ No newline at end of file + (require datalog/parse + datalog/tool/submit) + + ; XXX This is almost certainly wrong. + (define (even-read src ip) + (begin0 + (parameterize ([current-source-name src]) + (datum->syntax #f (parse-statement ip))) + (current-read-interaction odd-read))) + (define (odd-read src ip) + (current-read-interaction even-read) + eof) + + (current-read-interaction + even-read)) \ No newline at end of file diff --git a/collects/datalog/parse.rkt b/collects/datalog/parse.rkt index 5c3f116..f846055 100644 --- a/collects/datalog/parse.rkt +++ b/collects/datalog/parse.rkt @@ -104,6 +104,7 @@ A Datalog reader consumes a Datalog program. A program is a sequence of zero or (define parse-program (mk-parser program-parser)) (provide/contract + [current-source-name (parameter/c any/c)] [parse-literal (input-port? . -> . literal?)] [parse-clause (input-port? . -> . clause?)] [parse-statement (input-port? . -> . statement/c)] diff --git a/collects/datalog/scribblings/datalog.scrbl b/collects/datalog/scribblings/datalog.scrbl index 415929e..6aebe6f 100644 --- a/collects/datalog/scribblings/datalog.scrbl +++ b/collects/datalog/scribblings/datalog.scrbl @@ -125,7 +125,9 @@ The following is a program: END ] -Currently, REPL interaction is not supported. +The Datalog REPL accepts new statements that are executed as if they were in the original program text. + +@include-section["tutorial.scrbl"] @section{Parenthetical Datalog Module Language} @(require (for-label datalog/sexp/lang)) @@ -152,6 +154,8 @@ The following is a program: (path ,Z ,Y))) (? (path ,X ,Y))] +The Parenthetical Datalog REPL accepts new statements that are executed as if they were in the original program text. + @subsection[#:tag "parenstx"]{Parenthetical Syntax} @defmodule[datalog/sexp/lang] diff --git a/collects/datalog/scribblings/racket.scrbl b/collects/datalog/scribblings/racket.scrbl index 484bdd6..1c84a5c 100644 --- a/collects/datalog/scribblings/racket.scrbl +++ b/collects/datalog/scribblings/racket.scrbl @@ -197,6 +197,8 @@ This library provides facilities for parsing Datalog source. It can be required @defmodule[datalog/parse] +@defparam[current-source-name name any/c]{ A parameter used by the parsing functions to set the source name on the read ASTs. } + @defproc[(parse-literal [ip input-port?]) literal?]{ Parses a @racket[literal] from @racket[ip]. diff --git a/collects/datalog/scribblings/tutorial.scrbl b/collects/datalog/scribblings/tutorial.scrbl index 0bc80eb..e4c24bc 100644 --- a/collects/datalog/scribblings/tutorial.scrbl +++ b/collects/datalog/scribblings/tutorial.scrbl @@ -10,9 +10,11 @@ @title{Tutorial} -Start DrScheme and choose the @tt{Datalog} language from DrScheme's -@tt{Language} menu under @tt{Experimental Languages}. Click @onscreen{Run}, then -click in the REPL. +Start DrRacket and type + +@racketmod[datalog] + +in the Definitions window. Click @onscreen{Run}, then click in the REPL. @racketinput[] @@ -72,7 +74,7 @@ C is an ancestor of B, then A is an ancestor of B. #,(tt " parent(A, C),") #,(tt " ancestor(C, B).")] -In the interpreter, DrScheme knows that the clause is not complete, so by pressing Return, it doesn't interpret the line. +In the interpreter, DrRacket knows that the clause is not complete, so by pressing Return, it doesn't interpret the line. Rules are used to answer queries just as is done for facts. From 77b5b07e9b76437e3fd7b2b6fcf170ed8226e7e4 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Sat, 26 Jun 2010 13:08:10 -0600 Subject: [PATCH 16/28] Protecting :- outside clauses original commit: b126303628f4b1870094949558f89e587b044c97 --- collects/datalog/sexp/lang.rkt | 15 ++++++--------- 1 file changed, 6 insertions(+), 9 deletions(-) diff --git a/collects/datalog/sexp/lang.rkt b/collects/datalog/sexp/lang.rkt index 5aca47a..e85e850 100644 --- a/collects/datalog/sexp/lang.rkt +++ b/collects/datalog/sexp/lang.rkt @@ -4,6 +4,9 @@ "../eval.rkt" "../ast.rkt") +(define-syntax (:- stx) + (raise-syntax-error ':- "only allowed inside ! and ~" stx)) + (define-syntax-parameter top (λ (stx) (raise-syntax-error '#%top "undefined identifier" stx))) (define-syntax-parameter unquote @@ -48,20 +51,14 @@ (define-syntax (->simple-clause stx) (syntax-case stx (:-) - [(_ (:- . r)) + [(_ (:- head body ...)) (quasisyntax/loc stx - (:- . r))] + (clause #'#,stx (->literal head) + (list (->literal body) ...)))] [(_ e) (quasisyntax/loc stx (clause #'#,stx (->literal e) empty))])) -(define-syntax (:- stx) - (syntax-case stx () - [(_ head body ...) - (quasisyntax/loc stx - (clause #'#,stx (->literal head) - (list (->literal body) ...)))])) - (define-syntax-rule (define-paren-stx op struct) (define-syntax (op stx) (syntax-case stx () From ee39d5b701316be8ac8350644782a95afbba5022 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Sat, 26 Jun 2010 13:17:10 -0600 Subject: [PATCH 17/28] Use capitalized letters for variables in paren version original commit: 07142e230525211540dd080f1613f0cf5268b55b --- collects/datalog/scribblings/datalog.scrbl | 18 ++++++-------- collects/datalog/sexp/lang.rkt | 22 ++++++----------- .../tests/datalog/paren-examples/ancestor.rkt | 12 +++++----- .../tests/datalog/paren-examples/ancestor.txt | 6 ++--- .../tests/datalog/paren-examples/bidipath.rkt | 18 +++++++------- .../tests/datalog/paren-examples/laps.rkt | 14 +++++------ .../tests/datalog/paren-examples/path.rkt | 12 +++++----- collects/tests/datalog/paren-examples/pq.rkt | 10 ++++---- .../tests/datalog/paren-examples/revpath.rkt | 12 +++++----- .../tests/datalog/paren-examples/says.rkt | 8 +++---- .../tests/datalog/paren-examples/tutorial.rkt | 24 +++++++++---------- 11 files changed, 72 insertions(+), 84 deletions(-) diff --git a/collects/datalog/scribblings/datalog.scrbl b/collects/datalog/scribblings/datalog.scrbl index 6aebe6f..7f0a49f 100644 --- a/collects/datalog/scribblings/datalog.scrbl +++ b/collects/datalog/scribblings/datalog.scrbl @@ -136,9 +136,7 @@ The Datalog REPL accepts new statements that are executed as if they were in the The semantics of this language is the same as the normal Datalog language, except it uses a @secref["parenstx"]. -Literals are represented as S-expressions with identifiers for constant symbols, strings for constant strings, and @racket[,id] for variable symbols. - -@racket[unquote], top-level identifiers, and strings are not otherwise allowed in the program. +Literals are represented as S-expressions with non-capitalized identifiers for constant symbols, strings for constant strings, and capitalized identifiers for variable symbols. Top-level identifiers and strings are not otherwise allowed in the program. The following is a program: @racketmod[datalog/sexp @@ -147,12 +145,12 @@ The following is a program: (! (edge b c)) (! (edge c d)) (! (edge d a)) -(! (:- (path ,X ,Y) - (edge ,X ,Y))) -(! (:- (path ,X ,Y) - (edge ,X ,Z) - (path ,Z ,Y))) -(? (path ,X ,Y))] +(! (:- (path X Y) + (edge X Y))) +(! (:- (path X Y) + (edge X Z) + (path Z Y))) +(? (path X Y))] The Parenthetical Datalog REPL accepts new statements that are executed as if they were in the original program text. @@ -168,8 +166,6 @@ The Parenthetical Datalog REPL accepts new statements that are executed as if th @defform[(= term term)]{ An equality literal. } -@defform[(unquote symbol)]{ A variable symbol. } - @include-section["racket.scrbl"] @section{Acknowledgments} diff --git a/collects/datalog/sexp/lang.rkt b/collects/datalog/sexp/lang.rkt index e85e850..c1fc066 100644 --- a/collects/datalog/sexp/lang.rkt +++ b/collects/datalog/sexp/lang.rkt @@ -9,8 +9,6 @@ (define-syntax-parameter top (λ (stx) (raise-syntax-error '#%top "undefined identifier" stx))) -(define-syntax-parameter unquote - (λ (stx) (raise-syntax-error 'unquote "only allowed inside literals" stx))) (define-syntax-parameter datum (λ (stx) (raise-syntax-error '#%datum "only allowed inside literals" stx))) @@ -18,15 +16,11 @@ (syntax-parse stx [(_ . sym:id) - (quasisyntax/loc stx - (constant #'#,stx 'sym))])) - -(define-syntax (literal-unquote stx) - (syntax-parse - stx - [(_ sym:id) - (quasisyntax/loc stx - (variable #'#,stx 'sym))])) + (if (char-upper-case? (string-ref (symbol->string (syntax->datum #'sym)) 0)) + (quasisyntax/loc stx + (variable #'#,stx 'sym)) + (quasisyntax/loc stx + (constant #'#,stx 'sym)))])) (define-syntax (literal-datum stx) (syntax-parse @@ -45,8 +39,7 @@ (quasisyntax/loc stx (literal #'#,stx 'sym (syntax-parameterize ([top (make-rename-transformer #'literal-top)] - [datum (make-rename-transformer #'literal-datum)] - [unquote (make-rename-transformer #'literal-unquote)]) + [datum (make-rename-transformer #'literal-datum)]) (list e ...))))])) (define-syntax (->simple-clause stx) @@ -84,5 +77,4 @@ #%top-interaction #%module-begin ! ~ ? - :- = - unquote) \ No newline at end of file + :- =) \ No newline at end of file diff --git a/collects/tests/datalog/paren-examples/ancestor.rkt b/collects/tests/datalog/paren-examples/ancestor.rkt index 78e5f87..290994b 100644 --- a/collects/tests/datalog/paren-examples/ancestor.rkt +++ b/collects/tests/datalog/paren-examples/ancestor.rkt @@ -1,12 +1,12 @@ #lang datalog/sexp ; Equality test -(! (:- (ancestor ,A ,B) - (parent ,A ,B))) -(! (:- (ancestor ,A ,B) - (parent ,A ,C) +(! (:- (ancestor A B) + (parent A B))) +(! (:- (ancestor A B) + (parent A C) (= D C) ; Unification required - (ancestor ,D ,B))) + (ancestor D B))) (! (parent john douglas)) (! (parent bob john)) (! (parent ebbon bob)) -(? (ancestor ,A ,B)) +(? (ancestor A B)) diff --git a/collects/tests/datalog/paren-examples/ancestor.txt b/collects/tests/datalog/paren-examples/ancestor.txt index 27724bb..bed107f 100644 --- a/collects/tests/datalog/paren-examples/ancestor.txt +++ b/collects/tests/datalog/paren-examples/ancestor.txt @@ -1,6 +1,6 @@ -ancestor(ebbon, douglas). -ancestor(ebbon, john). -ancestor(bob, douglas). ancestor(ebbon, bob). ancestor(bob, john). ancestor(john, douglas). +ancestor(bob, douglas). +ancestor(ebbon, john). +ancestor(ebbon, douglas). diff --git a/collects/tests/datalog/paren-examples/bidipath.rkt b/collects/tests/datalog/paren-examples/bidipath.rkt index 9582561..5c32fbb 100644 --- a/collects/tests/datalog/paren-examples/bidipath.rkt +++ b/collects/tests/datalog/paren-examples/bidipath.rkt @@ -4,12 +4,12 @@ (! (edge b c)) (! (edge c d)) (! (edge d a)) -(! (:- (path ,X ,Y) - (edge ,X ,Y))) -(! (:- (path ,X ,Y) - (edge ,X ,Z) - (path ,Z ,Y))) -(! (:- (path ,X ,Y) - (path ,X ,Z) - (edge ,Z ,Y))) -(? (path ,X ,Y)) \ No newline at end of file +(! (:- (path X Y) + (edge X Y))) +(! (:- (path X Y) + (edge X Z) + (path Z Y))) +(! (:- (path X Y) + (path X Z) + (edge Z Y))) +(? (path X Y)) \ No newline at end of file diff --git a/collects/tests/datalog/paren-examples/laps.rkt b/collects/tests/datalog/paren-examples/laps.rkt index 4bf8304..66b38a9 100644 --- a/collects/tests/datalog/paren-examples/laps.rkt +++ b/collects/tests/datalog/paren-examples/laps.rkt @@ -2,12 +2,12 @@ ; Laps Test (! (contains ca store rams_couch rams)) (! (contains rams fetch rams_couch will)) -(! (:- (contains ca fetch ,Name ,Watcher) - (contains ca store ,Name ,Owner) - (contains ,Owner fetch ,Name ,Watcher))) +(! (:- (contains ca fetch Name Watcher) + (contains ca store Name Owner) + (contains Owner fetch Name Watcher))) (! (trusted ca)) -(! (:- (permit ,User ,Priv ,Name) - (contains ,Auth ,Priv ,Name ,User) - (trusted ,Auth))) -(? (permit ,User ,Priv ,Name)) +(! (:- (permit User Priv Name) + (contains Auth Priv Name User) + (trusted Auth))) +(? (permit User Priv Name)) diff --git a/collects/tests/datalog/paren-examples/path.rkt b/collects/tests/datalog/paren-examples/path.rkt index 31de89c..ba2768e 100644 --- a/collects/tests/datalog/paren-examples/path.rkt +++ b/collects/tests/datalog/paren-examples/path.rkt @@ -4,9 +4,9 @@ (! (edge b c)) (! (edge c d)) (! (edge d a)) -(! (:- (path ,X ,Y) - (edge ,X ,Y))) -(! (:- (path ,X ,Y) - (edge ,X ,Z) - (path ,Z ,Y))) -(? (path ,X ,Y)) +(! (:- (path X Y) + (edge X Y))) +(! (:- (path X Y) + (edge X Z) + (path Z Y))) +(? (path X Y)) diff --git a/collects/tests/datalog/paren-examples/pq.rkt b/collects/tests/datalog/paren-examples/pq.rkt index 1c08e17..fb0a3ec 100644 --- a/collects/tests/datalog/paren-examples/pq.rkt +++ b/collects/tests/datalog/paren-examples/pq.rkt @@ -1,8 +1,8 @@ #lang datalog/sexp ; p q test from Chen & Warren -(! (:- (q ,X) - (p ,X))) +(! (:- (q X) + (p X))) (! (q a)) -(! (:- (p ,X) - (q ,X))) -(? (q ,X)) +(! (:- (p X) + (q X))) +(? (q X)) diff --git a/collects/tests/datalog/paren-examples/revpath.rkt b/collects/tests/datalog/paren-examples/revpath.rkt index 33cc238..5899cdf 100644 --- a/collects/tests/datalog/paren-examples/revpath.rkt +++ b/collects/tests/datalog/paren-examples/revpath.rkt @@ -4,9 +4,9 @@ (! (edge b c)) (! (edge c d)) (! (edge d a)) -(! (:- (path ,X ,Y) - (edge ,X ,Y))) -(! (:- (path ,X ,Y) - (path ,X ,Z) - (edge ,Z ,Y))) -(? (path ,X ,Y)) \ No newline at end of file +(! (:- (path X Y) + (edge X Y))) +(! (:- (path X Y) + (path X Z) + (edge Z Y))) +(? (path X Y)) \ No newline at end of file diff --git a/collects/tests/datalog/paren-examples/says.rkt b/collects/tests/datalog/paren-examples/says.rkt index 1c10fb0..90c7f71 100644 --- a/collects/tests/datalog/paren-examples/says.rkt +++ b/collects/tests/datalog/paren-examples/says.rkt @@ -1,7 +1,7 @@ #lang datalog/sexp (! (tpme tpme1)) (! (ms m1 "TPME" tpme1 ek tp)) -(! (:- (says ,TPME ,M) - (tpme ,TPME) - (ms ,M "TPME" ,TPME ,A ,B))) -(? (says ,A ,B)) +(! (:- (says TPME M) + (tpme TPME) + (ms M "TPME" TPME A B))) +(? (says A B)) diff --git a/collects/tests/datalog/paren-examples/tutorial.rkt b/collects/tests/datalog/paren-examples/tutorial.rkt index 90e1d6c..6d51ed6 100644 --- a/collects/tests/datalog/paren-examples/tutorial.rkt +++ b/collects/tests/datalog/paren-examples/tutorial.rkt @@ -6,23 +6,23 @@ (! (parent bob john)) (! (parent ebbon bob)) -(? (parent ,A ,B)) +(? (parent A B)) -(? (parent john ,B)) +(? (parent john B)) -(? (parent ,A ,A)) +(? (parent A A)) -(! (:- (ancestor ,A ,B) - (parent ,A ,B))) -(! (:- (ancestor ,A ,B) - (parent ,A ,C) - (ancestor ,C ,B))) -(? (ancestor ,A ,B)) +(! (:- (ancestor A B) + (parent A B))) +(! (:- (ancestor A B) + (parent A C) + (ancestor C B))) +(? (ancestor A B)) -(? (ancestor ,X john)) +(? (ancestor X john)) (~ (parent bob john)) -(? (parent ,A ,B)) +(? (parent A B)) -(? (ancestor ,A ,B)) +(? (ancestor A B)) From abb211b522150b9080d335b849be37dfd7c519ee Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Sat, 26 Jun 2010 13:30:59 -0600 Subject: [PATCH 18/28] Reader refactor original commit: f7210b20cfae1a7d05a8f2d93482b098adefd920 --- collects/datalog/lang/reader.rkt | 19 +++++++++++-------- 1 file changed, 11 insertions(+), 8 deletions(-) diff --git a/collects/datalog/lang/reader.rkt b/collects/datalog/lang/reader.rkt index 7394896..1eddbdd 100644 --- a/collects/datalog/lang/reader.rkt +++ b/collects/datalog/lang/reader.rkt @@ -1,11 +1,9 @@ (module reader syntax/module-reader #:language 'datalog/lang/module - #:read (lambda ([in (current-input-port)]) - (let ([ast (parse-program in)]) - (list `(#%module-begin ,@ast)))) - #:read-syntax (lambda ([source-name #f] [in (current-input-port)]) - (let ([ast (parse-program in)]) - (list `(#%module-begin ,@ast)))) + #:read + (lambda ([in (current-input-port)]) + (this-read-syntax #f in)) + #:read-syntax this-read-syntax #:whole-body-readers? #t #:info (lambda (key defval default) ; XXX Should have different comment character key @@ -18,15 +16,20 @@ (require datalog/parse datalog/tool/submit) + (define (this-read-syntax [src #f] [in (current-input-port)]) + (parameterize ([current-source-name src]) + (let ([ast (parse-program in)]) + (list `(#%module-begin ,@ast))))) + ; XXX This is almost certainly wrong. (define (even-read src ip) (begin0 (parameterize ([current-source-name src]) - (datum->syntax #f (parse-statement ip))) + (datum->syntax #f (parse-statement ip))) (current-read-interaction odd-read))) (define (odd-read src ip) (current-read-interaction even-read) eof) - + (current-read-interaction even-read)) \ No newline at end of file From 062703ebba5ae5485154030087b0310bf38e4774 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Sat, 26 Jun 2010 13:36:33 -0600 Subject: [PATCH 19/28] Simplifying organization original commit: 6d3d135f4cc3c480dda283c0c240040f3cf14930 --- collects/datalog/lang/reader.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/datalog/lang/reader.rkt b/collects/datalog/lang/reader.rkt index 1eddbdd..67a6e72 100644 --- a/collects/datalog/lang/reader.rkt +++ b/collects/datalog/lang/reader.rkt @@ -1,5 +1,5 @@ (module reader syntax/module-reader - #:language 'datalog/lang/module + #:language 'datalog/lang/lang #:read (lambda ([in (current-input-port)]) (this-read-syntax #f in)) From 31bb2c96d54eed2ea4b68d27fc47730811e2278d Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Sat, 26 Jun 2010 15:25:07 -0600 Subject: [PATCH 20/28] Uses a more traditional read/expand/eval pipeline original commit: c48d1b58b43a89c357c9fd883563b94f434c7eec --- collects/datalog/lang/reader.rkt | 24 ++++----- collects/datalog/private/compiler.rkt | 70 +++++++++++++++++++++------ collects/tests/datalog/main.rkt | 7 +-- 3 files changed, 68 insertions(+), 33 deletions(-) diff --git a/collects/datalog/lang/reader.rkt b/collects/datalog/lang/reader.rkt index 67a6e72..a3e1dfd 100644 --- a/collects/datalog/lang/reader.rkt +++ b/collects/datalog/lang/reader.rkt @@ -1,31 +1,31 @@ (module reader syntax/module-reader - #:language 'datalog/lang/lang - #:read - (lambda ([in (current-input-port)]) - (this-read-syntax #f in)) + #:language 'datalog/sexp/lang + #:read (lambda ([in (current-input-port)]) (this-read-syntax #f in)) #:read-syntax this-read-syntax #:whole-body-readers? #t #:info (lambda (key defval default) ; XXX Should have different comment character key (case key [(drracket:submit-predicate) - repl-submit?] + (dynamic-require 'datalog/tool/submit 'repl-submit?)] [(color-lexer) - (dynamic-require `datalog/tool/syntax-color 'get-syntax-token)] + (dynamic-require 'datalog/tool/syntax-color 'get-syntax-token)] [else (default key defval)])) (require datalog/parse - datalog/tool/submit) + datalog/private/compiler) (define (this-read-syntax [src #f] [in (current-input-port)]) - (parameterize ([current-source-name src]) - (let ([ast (parse-program in)]) - (list `(#%module-begin ,@ast))))) + (list + (compile-program + (parameterize ([current-source-name src]) + (parse-program in))))) ; XXX This is almost certainly wrong. (define (even-read src ip) (begin0 - (parameterize ([current-source-name src]) - (datum->syntax #f (parse-statement ip))) + (compile-statement + (parameterize ([current-source-name src]) + (parse-statement ip))) (current-read-interaction odd-read))) (define (odd-read src ip) (current-read-interaction even-read) diff --git a/collects/datalog/private/compiler.rkt b/collects/datalog/private/compiler.rkt index 86fee23..1b61368 100644 --- a/collects/datalog/private/compiler.rkt +++ b/collects/datalog/private/compiler.rkt @@ -1,20 +1,58 @@ #lang racket/base (require racket/contract - "../ast.rkt" - (for-syntax racket/base)) -(require (for-template racket/base - "../eval.rkt")) - -(define (compile-module asts) - (with-syntax ([(s ...) asts]) - (syntax - (begin (eval-statement s) ...)))) - -(define (compile-stmt ast) - (with-syntax ([s ast]) - (syntax - (eval-statement s)))) + racket/match + datalog/ast + (only-in datalog/sexp/lang + ? :- ! ~)) +(require (for-template datalog/sexp/lang)) (provide/contract - [compile-module (list? . -> . syntax?)] - [compile-stmt (statement/c . -> . syntax?)]) \ No newline at end of file + [compile-program (program/c . -> . syntax?)] + [compile-statement (statement/c . -> . syntax?)]) + +(define (compile-program p) + (quasisyntax + (#%module-begin #,@(map compile-statement p)))) + +(define compile-statement + (match-lambda + [(assertion srcloc c) + (define srcstx (datum->syntax #f 'x srcloc)) + (quasisyntax/loc srcstx + (! #,(compile-clause c)))] + [(retraction srcloc c) + (define srcstx (datum->syntax #f 'x srcloc)) + (quasisyntax/loc srcstx + (~ #,(compile-clause c)))] + [(query srcloc l) + (define srcstx (datum->syntax #f 'x srcloc)) + (quasisyntax/loc srcstx + (? #,(compile-literal l)))])) + +(define compile-clause + (match-lambda + [(clause srcloc head (list)) + (define srcstx (datum->syntax #f 'x srcloc)) + (compile-literal head)] + [(clause srcloc head body) + (define srcstx (datum->syntax #f 'x srcloc)) + (quasisyntax/loc srcstx + (:- #,@(map compile-literal (list* head body))))])) + +(define compile-literal + (match-lambda + [(literal srcloc '= (and ts (app length 2))) + (define srcstx (datum->syntax #f 'x srcloc)) + (quasisyntax/loc srcstx + (= #,@(map compile-term ts)))] + [(literal srcloc pred ts) + (define srcstx (datum->syntax #f 'x srcloc)) + (quasisyntax/loc srcstx + (#,pred #,@(map compile-term ts)))])) + +(define compile-term + (match-lambda + [(variable srcloc sym) + (datum->syntax #f sym srcloc)] + [(constant srcloc sym) + (datum->syntax #f sym srcloc)])) diff --git a/collects/tests/datalog/main.rkt b/collects/tests/datalog/main.rkt index 2f5b15b..39b7b78 100644 --- a/collects/tests/datalog/main.rkt +++ b/collects/tests/datalog/main.rkt @@ -15,8 +15,7 @@ "private/variant.rkt" "runtime.rkt" - "eval.rkt" - "private/compiler.rkt") + "eval.rkt") (run-tests (test-suite @@ -35,6 +34,4 @@ variant-tests runtime-tests - eval-tests - - compiler-tests)) \ No newline at end of file + eval-tests)) \ No newline at end of file From a89d757639b932520d2dd848d9ecea011ebf6c60 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Sat, 26 Jun 2010 18:04:21 -0600 Subject: [PATCH 21/28] Using configure-runtime original commit: 4fe07902d98e1953574b37e1fea5c3890ce1b6e9 --- collects/datalog/lang/reader.rkt | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/collects/datalog/lang/reader.rkt b/collects/datalog/lang/reader.rkt index a3e1dfd..4f9886b 100644 --- a/collects/datalog/lang/reader.rkt +++ b/collects/datalog/lang/reader.rkt @@ -10,6 +10,9 @@ (dynamic-require 'datalog/tool/submit 'repl-submit?)] [(color-lexer) (dynamic-require 'datalog/tool/syntax-color 'get-syntax-token)] + [(configure-runtime) + (λ () + (current-read-interaction even-read))] [else (default key defval)])) (require datalog/parse datalog/private/compiler) @@ -29,7 +32,4 @@ (current-read-interaction odd-read))) (define (odd-read src ip) (current-read-interaction even-read) - eof) - - (current-read-interaction - even-read)) \ No newline at end of file + eof)) \ No newline at end of file From 96d80cf95a4fd503c73a487b433e8b48281185ee Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 28 Jun 2010 11:08:03 -0600 Subject: [PATCH 22/28] Using the datalog reader for racklog original commit: 12797fef41119f956e70537450a7f38339fa1d62 --- collects/datalog/eval.rkt | 1 + collects/datalog/lang/reader.rkt | 3 +-- collects/datalog/scribblings/datalog.scrbl | 2 +- collects/datalog/scribblings/racket.scrbl | 3 +++ collects/tests/racklog/lang/laps.txt | 2 ++ collects/tests/racklog/lang/long.txt | 1 + collects/tests/racklog/lang/says.txt | 1 + collects/tests/racklog/lang/true.txt | 1 + 8 files changed, 11 insertions(+), 3 deletions(-) create mode 100644 collects/tests/racklog/lang/laps.txt create mode 100644 collects/tests/racklog/lang/long.txt create mode 100644 collects/tests/racklog/lang/says.txt create mode 100644 collects/tests/racklog/lang/true.txt diff --git a/collects/datalog/eval.rkt b/collects/datalog/eval.rkt index 82bf6b3..82f6e67 100644 --- a/collects/datalog/eval.rkt +++ b/collects/datalog/eval.rkt @@ -54,6 +54,7 @@ (provide/contract [current-theory (parameter/c mutable-theory/c)] + [print-literals ((listof literal?) . -> . void)] [eval-program (program/c . -> . void)] [eval-top-level-statement (statement/c . -> . void)] [eval-statement (statement/c . -> . (or/c void (listof literal?)))] diff --git a/collects/datalog/lang/reader.rkt b/collects/datalog/lang/reader.rkt index 4f9886b..dce4324 100644 --- a/collects/datalog/lang/reader.rkt +++ b/collects/datalog/lang/reader.rkt @@ -11,8 +11,7 @@ [(color-lexer) (dynamic-require 'datalog/tool/syntax-color 'get-syntax-token)] [(configure-runtime) - (λ () - (current-read-interaction even-read))] + (λ () (current-read-interaction even-read))] [else (default key defval)])) (require datalog/parse datalog/private/compiler) diff --git a/collects/datalog/scribblings/datalog.scrbl b/collects/datalog/scribblings/datalog.scrbl index 7f0a49f..790d12b 100644 --- a/collects/datalog/scribblings/datalog.scrbl +++ b/collects/datalog/scribblings/datalog.scrbl @@ -22,7 +22,7 @@ on tabling intermediate results ensures that all queries terminate. @table-of-contents[] -@section{Datalog Module Language} +@section[#:tag "datalog"]{Datalog Module Language} @defmodulelang[datalog] diff --git a/collects/datalog/scribblings/racket.scrbl b/collects/datalog/scribblings/racket.scrbl index 1c84a5c..3f0c234 100644 --- a/collects/datalog/scribblings/racket.scrbl +++ b/collects/datalog/scribblings/racket.scrbl @@ -538,6 +538,9 @@ This library provides facilities for evaluating Datalog. It can be required via: The @tech{theory} used by @racket[eval-program] and @racket[eval-stmt]. } +@defproc[(print-literals [ls (listof literal?)]) void]{ + Pretty formats the literals for display. } + @defproc[(eval-program [p program/c]) void]{ Evaluates @racket[p] using @racket[(current-theory)] as the @tech{theory}, printing query answers as it goes. diff --git a/collects/tests/racklog/lang/laps.txt b/collects/tests/racklog/lang/laps.txt new file mode 100644 index 0000000..d87ea5f --- /dev/null +++ b/collects/tests/racklog/lang/laps.txt @@ -0,0 +1,2 @@ +permit(rams, store, rams_couch). +permit(will, fetch, rams_couch). diff --git a/collects/tests/racklog/lang/long.txt b/collects/tests/racklog/lang/long.txt new file mode 100644 index 0000000..ebf5669 --- /dev/null +++ b/collects/tests/racklog/lang/long.txt @@ -0,0 +1 @@ +this_is_a_long_identifier_and_tests_the_scanners_concat_when_read_with_a_small_buffer. diff --git a/collects/tests/racklog/lang/says.txt b/collects/tests/racklog/lang/says.txt new file mode 100644 index 0000000..473484a --- /dev/null +++ b/collects/tests/racklog/lang/says.txt @@ -0,0 +1 @@ +says(tpme1, m1). diff --git a/collects/tests/racklog/lang/true.txt b/collects/tests/racklog/lang/true.txt new file mode 100644 index 0000000..48eb7ed --- /dev/null +++ b/collects/tests/racklog/lang/true.txt @@ -0,0 +1 @@ +true. From 8eee85b8bb9835243135d0422972da55c644aa55 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 28 Jun 2010 13:22:53 -0600 Subject: [PATCH 23/28] Adding datalog macro original commit: da7d4d4042c24d6ccd49a104861af52cd64dd989 --- collects/datalog/lang/reader.rkt | 9 +- collects/datalog/main.rkt | 15 +- collects/datalog/private/compiler.rkt | 10 +- collects/datalog/runtime.rkt | 1 + collects/datalog/scribblings/datalog.scrbl | 18 +- collects/datalog/scribblings/racket.scrbl | 637 ++------------------ collects/datalog/scribblings/tutorial.scrbl | 2 +- collects/datalog/sexp/lang.rkt | 89 +-- collects/datalog/stx.rkt | 105 ++++ collects/tests/datalog/main.rkt | 10 +- collects/tests/datalog/racket.rkt | 57 ++ 11 files changed, 246 insertions(+), 707 deletions(-) create mode 100644 collects/datalog/stx.rkt create mode 100644 collects/tests/datalog/racket.rkt diff --git a/collects/datalog/lang/reader.rkt b/collects/datalog/lang/reader.rkt index dce4324..43f2068 100644 --- a/collects/datalog/lang/reader.rkt +++ b/collects/datalog/lang/reader.rkt @@ -17,17 +17,16 @@ datalog/private/compiler) (define (this-read-syntax [src #f] [in (current-input-port)]) - (list - (compile-program - (parameterize ([current-source-name src]) - (parse-program in))))) + (compile-program + (parameterize ([current-source-name src]) + (parse-program in)))) ; XXX This is almost certainly wrong. (define (even-read src ip) (begin0 (compile-statement (parameterize ([current-source-name src]) - (parse-statement ip))) + (parse-statement ip))) (current-read-interaction odd-read))) (define (odd-read src ip) (current-read-interaction even-read) diff --git a/collects/datalog/main.rkt b/collects/datalog/main.rkt index 1876c57..c693521 100644 --- a/collects/datalog/main.rkt +++ b/collects/datalog/main.rkt @@ -1,11 +1,6 @@ #lang racket -(require "ast.rkt" - "parse.rkt" - "pretty.rkt" - "runtime.rkt" - "eval.rkt") -(provide (all-from-out "ast.rkt" - "parse.rkt" - "pretty.rkt" - "runtime.rkt" - "eval.rkt")) \ No newline at end of file +(require "runtime.rkt" + "stx.rkt") +(provide make-theory + mutable-theory/c + (all-from-out "stx.rkt")) \ No newline at end of file diff --git a/collects/datalog/private/compiler.rkt b/collects/datalog/private/compiler.rkt index 1b61368..2b96bc1 100644 --- a/collects/datalog/private/compiler.rkt +++ b/collects/datalog/private/compiler.rkt @@ -2,17 +2,15 @@ (require racket/contract racket/match datalog/ast - (only-in datalog/sexp/lang - ? :- ! ~)) -(require (for-template datalog/sexp/lang)) + datalog/stx) +(require (for-template datalog/stx)) (provide/contract - [compile-program (program/c . -> . syntax?)] + [compile-program (program/c . -> . (listof syntax?))] [compile-statement (statement/c . -> . syntax?)]) (define (compile-program p) - (quasisyntax - (#%module-begin #,@(map compile-statement p)))) + (map compile-statement p)) (define compile-statement (match-lambda diff --git a/collects/datalog/runtime.rkt b/collects/datalog/runtime.rkt index e6837b1..a7a0fea 100644 --- a/collects/datalog/runtime.rkt +++ b/collects/datalog/runtime.rkt @@ -126,6 +126,7 @@ [theory/c contract?] [immutable-theory/c contract?] [mutable-theory/c contract?] + [rename make-mutable-theory make-theory (-> mutable-theory/c)] [make-mutable-theory (-> mutable-theory/c)] [make-immutable-theory (-> immutable-theory/c)] [assume (immutable-theory/c safe-clause? . -> . immutable-theory/c)] diff --git a/collects/datalog/scribblings/datalog.scrbl b/collects/datalog/scribblings/datalog.scrbl index 790d12b..367feb9 100644 --- a/collects/datalog/scribblings/datalog.scrbl +++ b/collects/datalog/scribblings/datalog.scrbl @@ -24,7 +24,7 @@ on tabling intermediate results ensures that all queries terminate. @section[#:tag "datalog"]{Datalog Module Language} -@defmodulelang[datalog] +@defmodulelang[@racketmodname[datalog] #:module-paths (datalog/lang/reader)] In Datalog input, whitespace characters are ignored except when they separate adjacent tokens or when they occur in strings. Comments are also considered to be whitespace. The character @litchar["%"] introduces a comment, which extends to the next line break. @@ -130,11 +130,11 @@ The Datalog REPL accepts new statements that are executed as if they were in the @include-section["tutorial.scrbl"] @section{Parenthetical Datalog Module Language} -@(require (for-label datalog/sexp/lang)) +@(require (for-label datalog)) @defmodulelang[datalog/sexp] -The semantics of this language is the same as the normal Datalog language, except it uses a @secref["parenstx"]. +The semantics of this language is the same as the normal Datalog language, except it uses a parenthetical syntax. Literals are represented as S-expressions with non-capitalized identifiers for constant symbols, strings for constant strings, and capitalized identifiers for variable symbols. Top-level identifiers and strings are not otherwise allowed in the program. @@ -154,18 +154,6 @@ The following is a program: The Parenthetical Datalog REPL accepts new statements that are executed as if they were in the original program text. -@subsection[#:tag "parenstx"]{Parenthetical Syntax} - -@defmodule[datalog/sexp/lang] - -@defform[(! clause)]{ Asserts the clause. } -@defform[(~ clause)]{ Retracts the literal. } -@defform[(? literal)]{ Queries the literal and prints the result literals. } - -@defform[(:- literal literal ...)]{ A conditional clause. } - -@defform[(= term term)]{ An equality literal. } - @include-section["racket.scrbl"] @section{Acknowledgments} diff --git a/collects/datalog/scribblings/racket.scrbl b/collects/datalog/scribblings/racket.scrbl index 3f0c234..195a7a1 100644 --- a/collects/datalog/scribblings/racket.scrbl +++ b/collects/datalog/scribblings/racket.scrbl @@ -10,610 +10,59 @@ @title{Racket Interoperability} -@defmodule[datalog/main] +@defmodule[datalog] The Datalog database can be directly used by Racket programs through this API. @examples[#:eval the-eval - (define example-program - #<syntax]. + (define family (make-theory)) + + (datalog family + (! (parent joseph2 joseph1)) + (! (parent joseph2 lucy)) + (! (parent joseph3 joseph2))) + + (datalog family + (? (parent X joseph2))) - Equivalent to - @racketblock[ - (or/c syntax? - false/c - (list/c any/c - (or/c exact-positive-integer? #f) - (or/c exact-nonnegative-integer? #f) - (or/c exact-nonnegative-integer? #f) - (or/c exact-positive-integer? #f))) - ] -} - -@defthing[datum/c contract?]{ - Contract for @deftech{datum}s. - Equivalent to @racket[(or/c string? symbol?)]. -} - -@defproc[(datum-equal? [d1 datum/c] [d2 datum/c]) - boolean?]{ - Equivalent to @racket[(equal? d1 d2)]. - - @examples[#:eval the-eval - (datum-equal? 'sym1 'sym2) - (datum-equal? 'sym1 'sym1) - (datum-equal? "str1" "str2") - (datum-equal? "str1" "str1")] -} - -@defstruct[variable ([srcloc srcloc/c] - [sym symbol?])]{ - A logic variable in Datalog. - (This structure does not enforce the requirements for what characters variables can contain, so if you print one out, - it might not be parseable, but it will be executeable.) -} - -@defproc[(variable-equal? [v1 variable?] [v2 variable?]) - boolean?]{ - Equivalent to @racket[(equal? v1 v2)] modulo source location. - - @examples[#:eval the-eval - (variable-equal? (make-variable #f 'sym) - (make-variable #'sym 'sym)) - (variable-equal? (make-variable #f 'sym1) - (make-variable #f 'sym2))] -} - -@defstruct[constant ([srcloc srcloc/c] - [datum datum/c])]{ - A constant in Datalog. - (This structure does not enforce the requirements for what characters constants can contain, so if you print one out, - it might not be parseable, but it will be executeable.) -} - -@defproc[(constant-equal? [c1 constant?] [c2 constant?]) - boolean?]{ - Equivalent to @racket[(equal? c1 c2)] modulo source location. - - @examples[#:eval the-eval - (constant-equal? (make-constant #f 'sym) - (make-constant #'sym 'sym)) - (constant-equal? (make-constant #f 'sym) - (make-constant #f "str"))] -} - -@defthing[term/c contract?]{ - Contract for @deftech{term}s. Equivalent to @racket[(or/c variable? constant?)]. -} - -@defproc[(term-equal? [t1 term/c] [t2 term/c]) - boolean?]{ - Equivalent to @racket[(equal? t1 t2)] modulo source location. - - @examples[#:eval the-eval - (term-equal? (make-constant #f 'sym) (make-constant #'sym 'sym)) - (term-equal? (make-constant #f 'sym) (make-constant #f "str"))] -} - -@defstruct[literal ([srcloc srcloc/c] - [predicate datum/c] - [terms (listof term/c)])]{ - A literal in Datalog. -} - -@defproc[(literal-equal? [l1 literal?] [l2 literal?]) - boolean?]{ - Equivalent to @racket[(equal? l1 l2)] modulo source location. - - @examples[#:eval the-eval - (literal-equal? (make-literal #f 'ancestor (list)) - (make-literal #'ancestor 'ancestor (list))) - (literal-equal? (make-literal #f 'ancestor (list)) - (make-literal #f 'parent (list))) - (literal-equal? (make-literal #f 'ancestor (list)) - (make-literal #f 'ancestor - (list (make-constant #f 'jack))))] -} - -@defstruct[clause ([srcloc srcloc/c] - [head literal?] - [body (listof literal?)])]{ - A Datalog clause. -} - -@defproc[(clause-equal? [c1 clause?] [c2 clause?]) - boolean?]{ - Equivalent to @racket[(equal? c1 c2)] modulo source location. - - @examples[#:eval the-eval - (clause-equal? - (make-clause #f (make-literal #f 'ancestor (list)) (list)) - (make-clause #'clause - (make-literal #f 'ancestor (list)) (list))) - (clause-equal? - (make-clause #f (make-literal #f 'ancestor (list)) (list)) - (make-clause #f (make-literal #f 'parent (list)) (list)))] -} - -@defstruct[assertion ([srcloc srcloc/c] - [clause clause?])]{ - A Datalog assertion. -} - -@defstruct[retraction ([srcloc srcloc/c] - [clause clause?])]{ - A Datalog retraction. -} - -@defstruct[query ([srcloc srcloc/c] - [literal literal?])]{ - A Datalog query. -} - -@defthing[statement/c contract?]{ - Contract for @deftech{statement}s. - Equivalent to @racket[(or/c assertion? retraction? query?)]. -} - -@defthing[program/c contract?]{ - Contract for @deftech{program}s. - Equivalent to @racket[(listof statement/c)]. -} - -@section{Datalog Parsing} - -This library provides facilities for parsing Datalog source. It can be required via: - -@defmodule[datalog/parse] - -@defparam[current-source-name name any/c]{ A parameter used by the parsing functions to set the source name on the read ASTs. } - -@defproc[(parse-literal [ip input-port?]) - literal?]{ - Parses a @racket[literal] from @racket[ip]. - - @examples[#:eval the-eval - (parse-literal (open-input-string "parent(john,douglas)")) - (parse-literal (open-input-string "zero-arity-literal")) - (parse-literal (open-input-string "\"=\"(3,3)")) - (parse-literal - (open-input-string "\"\"(-0-0-0,&&&,***,\"\00\")")) - (parse-literal (open-input-string "3 = 3"))] -} - -@defproc[(parse-clause [ip input-port?]) - clause?]{ - Parses a @racket[clause] from @racket[ip]. - - @examples[#:eval the-eval - (parse-clause - (open-input-string "parent(john, douglas)")) - (parse-clause - (open-input-string "ancestor(A, B) :- parent(A, B)")) - (parse-clause - (open-input-string - (string-append "ancestor(A, B) :- parent(A, C)," - "ancestor(C, B)")))] -} - -@defproc[(parse-statement [ip input-port?]) - statement/c]{ - Parses a @tech{statement} from @racket[ip]. - - @examples[#:eval the-eval - (parse-statement - (open-input-string "parent(john, douglas).")) - (parse-statement - (open-input-string "parent(john, douglas)~")) - (parse-statement - (open-input-string "parent(john, douglas)?"))] -} - -@defproc[(parse-program [ip input-port?]) - program/c]{ - Parses a @tech{program} from @racket[ip]. - - @examples[#:eval the-eval - (parse-program - (open-input-string - (string-append - "edge(a, b). edge(b, c)." - "edge(c, d). edge(d, a)." - "path(X, Y) :- edge(X, Y)." - "path(X, Y) :- edge(X, Z), path(Z, Y)." - "path(X, Y)?")))] -} - -@section{Pretty-Printing} - -This library provides facilities for pretty-printing Datalog source. It can be required via: - -@defmodule[datalog/pretty] - -@defproc[(format-datum [d datum/c]) - string?]{ - Formats a @tech{datum}. - - @examples[#:eval the-eval - (format-datum 'sym) - (format-datum "str")] -} - -@defproc[(format-variable [v variable?]) - string?]{ - Formats a @racket[variable]. - - @examples[#:eval the-eval - (format-variable (make-variable #f 'Ancestor))] -} - -@defproc[(format-constant [c constant?]) - string?]{ - Formats a @racket[constant]. - - @examples[#:eval the-eval - (format-constant (make-constant #f 'joseph)) - (format-constant (make-constant #f "whom"))] -} + (datalog family + (? (parent joseph2 X))) -@defproc[(format-term [t term/c]) - string?]{ - Formats a @tech{term}. - - @examples[#:eval the-eval - (format-term (make-variable #f 'Ancestor)) - (format-term (make-constant #f 'joseph)) - (format-term (make-constant #f "whom"))] -} - -@defproc[(format-literal [l literal?]) - string?]{ - Formats a @racket[literal]. - - @examples[#:eval the-eval - (format-literal (make-literal #f 'true (list))) - (format-literal - (make-literal #f 'ancestor - (list (make-variable #f 'A) (make-constant #f 'jay)))) - (format-literal - (make-literal #f '= - (list (make-constant #f 'joseph) (make-constant #f 'jay))))] -} - -@defproc[(format-literals [ls (listof literal?)]) - string?]{ - Formats a list of @racket[literal]s as @racket[assertion]s for formatting @racket[prove] results. - - @examples[#:eval the-eval - (format-literals - (list - (make-literal #f 'true (list)) - (make-literal #f 'ancestor - (list (make-constant #f 'joseph) (make-constant #f 'jay))) - (make-literal #f '= - (list (make-constant #f 'joseph) (make-constant #f 'jay)))))] -} - -@defproc[(format-clause [c clause?]) - string?]{ - Formats a @racket[clause]. - - @examples[#:eval the-eval - (format-clause - (make-clause - #f (make-literal #f 'ancestor - (list (make-constant #f 'joseph) - (make-constant #f 'jay))) - (list))) - (format-clause - (make-clause - #f (make-literal - #f 'ancestor - (list (make-constant #f 'A) (make-constant #f 'B))) - (list (make-literal - #f 'parent - (list (make-constant #f 'A) (make-constant #f 'B)))))) - (format-clause - (make-clause - #f (make-literal - #f 'ancestor - (list (make-constant #f 'A) (make-constant #f 'B))) - (list (make-literal - #f 'parent - (list (make-constant #f 'A) (make-constant #f 'C))) - (make-literal - #f 'ancestor - (list (make-constant #f 'C) (make-constant #f 'B))))))] -} - -@defproc[(format-assertion [a assertion?]) - string?]{ - Formats a @racket[assertion]. - - @examples[#:eval the-eval - (format-assertion - (make-assertion - #f (make-clause - #f (make-literal #f 'ancestor - (list (make-constant #f 'joseph) - (make-constant #f 'jay))) - (list))))] -} - -@defproc[(format-retraction [r retraction?]) - string?]{ - Formats a @racket[retraction]. - - @examples[#:eval the-eval - (format-retraction - (make-retraction - #f (make-clause - #f (make-literal #f 'ancestor - (list (make-constant #f 'joseph) - (make-constant #f 'jay))) - (list))))] -} - -@defproc[(format-query [q query?]) - string?]{ - Formats a @racket[query]. - - @examples[#:eval the-eval - (format-query - (make-query - #f (make-literal #f 'ancestor - (list (make-constant #f 'joseph) - (make-constant #f 'jay)))))] -} - -@defproc[(format-statement [s statement/c]) - string?]{ - Formats a @tech{statement}. - - @examples[#:eval the-eval - (format-statement - (make-query - #f (make-literal #f 'ancestor - (list (make-constant #f 'joseph) - (make-constant #f 'jay)))))] -} - -@defproc[(format-program [p program/c]) - string?]{ - Formats a @tech{program}. - - @examples[#:eval the-eval - (format-program - (list - (make-assertion - #f (make-clause - #f (make-literal #f 'ancestor - (list (make-constant #f 'joseph) - (make-constant #f 'jay))) - (list))) - (make-query - #f (make-literal #f 'ancestor - (list (make-constant #f 'joseph) - (make-constant #f 'jay))))))] -} - -@section{Runtime System} - -This library implements the Datalog runtime system. It can be required via: - -@defmodule[datalog/runtime] - -@defthing[theory/c contract?]{ - A contract for @deftech{theories}. -} - -@defthing[immutable-theory/c contract?]{ - A contract for immutable @tech{theories}. -} - -@defthing[mutable-theory/c contract?]{ - A contract for mutable @tech{theories}. -} - -@defproc[(make-mutable-theory) - mutable-theory/c]{ - Constructs a mutable @tech{theory}. -} - -@defproc[(make-immutable-theory) - immutable-theory/c]{ - Constructs a immutable @tech{theory}. -} - -@defproc[(safe-clause? [c clause?]) - boolean?]{ - Determines if a @racket[clause] is safe. - A @racket[clause] is safe if every @racket[variable] in its head occurs in some @racket[literal] in its body. + (datalog family + (? (parent joseph2 X)) + (? (parent X joseph2))) - @examples[#:eval the-eval - (safe-clause? - (parse-clause (open-input-string "ancestor(joseph,jay)"))) - (safe-clause? - (parse-clause - (open-input-string "ancestor(A,B) :- parent(A,B)"))) - (safe-clause? - (parse-clause - (open-input-string "ancestor(A,B) :- parent(A,jay)")))] -} - -@defproc[(assume [thy immutable-theory/c] - [c safe-clause?]) - immutable-theory/c]{ - Adds @racket[c] to @racket[thy] in a persistent way. -} - -@defproc[(retract [thy immutable-theory/c] - [c clause?]) - immutable-theory/c]{ - Removes @racket[c] from @racket[thy] in a persistent way. -} - -@defproc[(assume! [thy mutable-theory/c] - [c safe-clause?]) - mutable-theory/c]{ - Adds @racket[c] to @racket[thy]. -} - -@defproc[(retract! [thy mutable-theory/c] - [c clause?]) - mutable-theory/c]{ - Removes @racket[c] from @racket[thy]. -} - -@defproc[(prove [thy theory/c] - [l literal?]) - (listof literal?)]{ - Attempts to prove @racket[l] using the @tech{theory} @racket[thy], returning all - the results of the query. + (datalog family + (! (:- (ancestor A B) + (parent A B))) + (! (:- (ancestor A B) + (parent A C) + (= D C) + (ancestor D B)))) - @examples[#:eval the-eval - (format-literals - (prove - (assume - (make-immutable-theory) - (parse-clause (open-input-string "parent(joseph1,joseph2)"))) - (parse-literal - (open-input-string "parent(joseph1,joseph2)")))) - (format-literals - (prove - (retract - (assume - (make-immutable-theory) - (parse-clause - (open-input-string "parent(joseph1,joseph2)"))) - (parse-clause (open-input-string "parent(joseph1,joseph2)"))) - (parse-literal - (open-input-string "parent(joseph1,joseph2)")))) - (format-literals - (prove - (assume - (make-immutable-theory) - (parse-clause (open-input-string "parent(joseph1,joseph2)"))) - (parse-literal (open-input-string "parent(A,B)"))))] -} - -@section{Evaluation} - -This library provides facilities for evaluating Datalog. It can be required via: - -@defmodule[datalog/eval] - -@defthing[current-theory (parameter/c mutable-theory/c)]{ - The @tech{theory} used by @racket[eval-program] and @racket[eval-stmt]. -} - -@defproc[(print-literals [ls (listof literal?)]) void]{ - Pretty formats the literals for display. } - -@defproc[(eval-program [p program/c]) - void]{ - Evaluates @racket[p] using @racket[(current-theory)] as the @tech{theory}, printing query answers as it goes. - - This will raise a syntax error if given an @racket[assertion] of a @racket[clause] that is not a @racket[safe-clause?]. + (datalog family + (? (ancestor A B))) - @examples[#:eval the-eval - (parameterize ([current-theory (make-mutable-theory)]) - (eval-program - (parse-program - (open-input-string - (string-append - "edge(a, b). edge(b, c). edge(c, d). edge(d, a)." - "path(X, Y) :- edge(X, Y)." - "path(X, Y) :- edge(X, Z), path(Z, Y)." - "path(X, Y)?"))))) - (eval-program - (parse-program - (open-input-string - "path(X, Y) :- edge(X, a).")))] -} + (let ([x 'joseph2]) + (datalog family + (? (parent x X))))] -@defproc[(eval-top-level-statement [s statement/c]) - void]{ - Evaluates @racket[s] using @racket[(current-theory)] as the @tech{theory}, printing query answers if @racket[s] is a query. - - This will raise a syntax error if given an @racket[assertion] of a @racket[clause] that is not a @racket[safe-clause?]. - } - -@defproc[(eval-statement [s statement/c]) - (or/c void (listof literal?))]{ - Evaluates @racket[s] using @racket[(current-theory)] as the @tech{theory}. - - This will raise a syntax error if given an @racket[assertion] of a @racket[clause] that is not a @racket[safe-clause?]. +@defthing[mutable-theory/c contract?]{ A contract for Datalog theories. } - @examples[#:eval the-eval - (parameterize ([current-theory (make-mutable-theory)]) - (eval-statement - (parse-statement - (open-input-string - "edge(a, b)."))) - (eval-statement - (parse-statement - (open-input-string - "path(X, Y) :- edge(X, Y)."))) - (eval-statement - (parse-statement - (open-input-string - "path(X, Y)?")))) - (eval-statement - (parse-statement - (open-input-string - "path(X, Y) :- edge(X, a).")))] -} - -@defproc[(eval-program/fresh [p program/c]) - immutable-theory/c]{ - Evaluates @racket[p] in a fresh @tech{theory} and returns the final @tech{theory}, printing query answers as it goes. +@defproc[(make-theory) mutable-theory/c]{ Creates a theory for use with @racket[datalog]. } - This will raise a syntax error if given an @racket[assertion] of a @racket[clause] that is not a @racket[safe-clause?]. +@defform[(datalog thy-expr + stmt ...) + #:contracts ([thy-expr mutable-theory/c])]{ Executes the statements on the theory given by @racket[thy-expr]. Returns the answers to the final query as a list of S-expressions or returns @racket[empty]. } + +@defform[(datalog! thy-expr + stmt ...) + #:contracts ([thy-expr mutable-theory/c])]{ Executes the statements on the theory given by @racket[thy-expr]. Prints the answers to every query in the list of statements. Returns @racket[(void)]. } + +Literals are represented as S-expressions with non-capitalized identifiers for constant symbols, strings for constant strings, and capitalized identifiers for variable symbols. Bound identifiers are treated as constants; they must evaluate to either a symbol or string. - @examples[#:eval the-eval - (void - (eval-program/fresh - (parse-program - (open-input-string - (string-append - "edge(a, b). edge(b, c). edge(c, d). edge(d, a)." - "path(X, Y) :- edge(X, Y)." - "path(X, Y) :- edge(X, Z), path(Z, Y)." - "path(X, Y)?"))))) - (eval-program/fresh - (parse-program - (open-input-string - "path(X, Y) :- edge(X, a).")))] -} \ No newline at end of file +@defform[(! clause)]{ Asserts the clause. } +@defform[(~ clause)]{ Retracts the literal. } +@defform[(? literal)]{ Queries the literal and prints the result literals. } + +@defform[(:- literal literal ...)]{ A conditional clause. } \ No newline at end of file diff --git a/collects/datalog/scribblings/tutorial.scrbl b/collects/datalog/scribblings/tutorial.scrbl index e4c24bc..d49973e 100644 --- a/collects/datalog/scribblings/tutorial.scrbl +++ b/collects/datalog/scribblings/tutorial.scrbl @@ -24,7 +24,7 @@ this: @racketinput[#,(tt "parent(john, douglas).")] -Each item in the parenthesized list following the name of the table is called a @tech{term}. +Each item in the parenthesized list following the name of the table is called a @deftech{term}. A term can be either a logical @racket[variable] or a @racket[constant]. Thus far, all the terms shown have been constant terms. diff --git a/collects/datalog/sexp/lang.rkt b/collects/datalog/sexp/lang.rkt index c1fc066..addccfb 100644 --- a/collects/datalog/sexp/lang.rkt +++ b/collects/datalog/sexp/lang.rkt @@ -1,80 +1,21 @@ #lang racket (require (for-syntax syntax/parse) - racket/stxparam - "../eval.rkt" - "../ast.rkt") + datalog/stx + datalog/runtime) -(define-syntax (:- stx) - (raise-syntax-error ':- "only allowed inside ! and ~" stx)) +(define lang-theory (make-theory)) -(define-syntax-parameter top - (λ (stx) (raise-syntax-error '#%top "undefined identifier" stx))) -(define-syntax-parameter datum - (λ (stx) (raise-syntax-error '#%datum "only allowed inside literals" stx))) +(define-syntax module-begin + (syntax-rules () + [(_ stmt ...) + (#%module-begin + (datalog! lang-theory stmt ...))])) -(define-syntax (literal-top stx) - (syntax-parse - stx - [(_ . sym:id) - (if (char-upper-case? (string-ref (symbol->string (syntax->datum #'sym)) 0)) - (quasisyntax/loc stx - (variable #'#,stx 'sym)) - (quasisyntax/loc stx - (constant #'#,stx 'sym)))])) +(define-syntax top-interaction + (syntax-rules () + [(_ . stmt) + (datalog! lang-theory stmt)])) -(define-syntax (literal-datum stx) - (syntax-parse - stx - [(_ . sym:str) - (quasisyntax/loc stx - (constant #'#,stx 'sym))])) - -(define-syntax (->literal stx) - (syntax-parse - stx - [(_ sym:id) - (quasisyntax/loc stx - (literal #'#,stx 'sym empty))] - [(_ (sym:id e ...)) - (quasisyntax/loc stx - (literal #'#,stx 'sym - (syntax-parameterize ([top (make-rename-transformer #'literal-top)] - [datum (make-rename-transformer #'literal-datum)]) - (list e ...))))])) - -(define-syntax (->simple-clause stx) - (syntax-case stx (:-) - [(_ (:- head body ...)) - (quasisyntax/loc stx - (clause #'#,stx (->literal head) - (list (->literal body) ...)))] - [(_ e) - (quasisyntax/loc stx - (clause #'#,stx (->literal e) empty))])) - -(define-syntax-rule (define-paren-stx op struct) - (define-syntax (op stx) - (syntax-case stx () - [(_ c) - (quasisyntax/loc stx - (eval-top-level-statement (struct #'#,stx (->simple-clause c))))]))) - -(define-paren-stx ! assertion) -(define-paren-stx ~ retraction) - -(define-syntax (? stx) - (syntax-case stx () - [(_ c) - (quasisyntax/loc stx - (eval-top-level-statement (query #'#,stx (->literal c))))])) - -(define-syntax (= stx) - (quasisyntax/loc stx - (constant #'#,stx '=))) - -(provide (rename-out [top #%top] - [datum #%datum]) - #%top-interaction - #%module-begin - ! ~ ? - :- =) \ No newline at end of file +(provide (rename-out [top-interaction #%top-interaction] + [module-begin #%module-begin]) + ! ~ ? :-) \ No newline at end of file diff --git a/collects/datalog/stx.rkt b/collects/datalog/stx.rkt new file mode 100644 index 0000000..9cff0b9 --- /dev/null +++ b/collects/datalog/stx.rkt @@ -0,0 +1,105 @@ +#lang racket +(require (for-syntax syntax/parse) + datalog/ast + datalog/eval) + +(define-syntax (:- stx) + (raise-syntax-error ':- "only allowed inside ! and ~" stx)) +(define-syntax (! stx) + (raise-syntax-error '! "only allowed inside datalog" stx)) +(define-syntax (~ stx) + (raise-syntax-error '~ "only allowed inside datalog" stx)) +(define-syntax (? stx) + (raise-syntax-error '? "only allowed inside datalog" stx)) + +(define ->answer + (match-lambda + [(? void?) + empty] + [(? list? ls) + (map literal->sexp ls)])) + +(define literal->sexp + (match-lambda + [(literal _ pred ts) + (list* pred (map term->datum ts))])) + +(define term->datum + (match-lambda + [(constant _ v) + v])) + +(define-syntax (datalog stx) + (syntax-case stx () + [(_ thy-expr stmt ...) + (syntax/loc stx + (parameterize ([current-theory thy-expr]) + (->answer (eval-statement (datalog-stmt stmt))) + ...))])) + +(define-syntax (datalog! stx) + (syntax-case stx () + [(_ thy-expr stmt ...) + (syntax/loc stx + (parameterize ([current-theory thy-expr]) + (eval-top-level-statement (datalog-stmt stmt)) + ...))])) + +(define-syntax (datalog-stmt stx) + (syntax-parse + stx + #:literals (! ~ ?) + [(_ (! c)) + (quasisyntax/loc stx + (assertion #'#,stx (datalog-clause c)))] + [(_ (~ c)) + (quasisyntax/loc stx + (retraction #'#,stx (datalog-clause c)))] + [(_ (? l)) + (quasisyntax/loc stx + (query #'#,stx (datalog-literal l)))])) + +(define-syntax (datalog-clause stx) + (syntax-parse + stx + #:literals (:-) + [(_ (:- head body ...)) + (quasisyntax/loc stx + (clause #'#,stx (datalog-literal head) + (list (datalog-literal body) ...)))] + [(_ e) + (quasisyntax/loc stx + (clause #'#,stx (datalog-literal e) empty))])) + +(define-syntax (datalog-literal stx) + (syntax-parse + stx + [(_ sym:id) + (quasisyntax/loc stx + (literal #'#,stx 'sym empty))] + [(_ (sym:id e ...)) + (quasisyntax/loc stx + (literal #'#,stx 'sym + (list (datalog-term e) + ...)))])) + +(define-syntax (datalog-term stx) + (syntax-parse + stx + [(_ sym:str) + (quasisyntax/loc stx + (constant #'#,stx 'sym))] + [(_ sym:id) + (cond + [(identifier-binding #'sym 0) + (quasisyntax/loc stx + (constant #'#,stx sym))] + [(char-upper-case? (string-ref (symbol->string (syntax->datum #'sym)) 0)) + (quasisyntax/loc stx + (variable #'#,stx 'sym))] + [else + (quasisyntax/loc stx + (constant #'#,stx 'sym))])])) + +(provide datalog datalog! + :- ! ~ ?) diff --git a/collects/tests/datalog/main.rkt b/collects/tests/datalog/main.rkt index 39b7b78..1f4a66b 100644 --- a/collects/tests/datalog/main.rkt +++ b/collects/tests/datalog/main.rkt @@ -1,5 +1,6 @@ #lang racket -(require rackunit +(require racket/runtime-path + rackunit rackunit/text-ui "ast.rkt" @@ -17,6 +18,8 @@ "runtime.rkt" "eval.rkt") +(define-runtime-path racket-mod "racket.rkt") + (run-tests (test-suite "Datalog" @@ -34,4 +37,7 @@ variant-tests runtime-tests - eval-tests)) \ No newline at end of file + eval-tests + + (test-case "Racket Interop" + (dynamic-require racket-mod #f)))) \ No newline at end of file diff --git a/collects/tests/datalog/racket.rkt b/collects/tests/datalog/racket.rkt new file mode 100644 index 0000000..39a6716 --- /dev/null +++ b/collects/tests/datalog/racket.rkt @@ -0,0 +1,57 @@ +#lang racket +(require datalog tests/eli-tester) + +(define parent (make-theory)) + +(test + (datalog parent + (! (parent joseph2 joseph1)) + (! (parent joseph2 lucy)) + (! (parent joseph3 joseph2))) + => + empty + + (datalog parent + (? (parent X joseph2))) + => + (list '(parent joseph3 joseph2)) + + (datalog parent + (? (parent joseph2 X))) + => + (list '(parent joseph2 joseph1) + '(parent joseph2 lucy)) + + (datalog parent + (? (parent joseph2 X)) + (? (parent X joseph2))) + => + (list '(parent joseph3 joseph2)) + + (datalog parent + (! (:- (ancestor A B) + (parent A B))) + (! (:- (ancestor A B) + (parent A C) + (= D C) ; Unification required + (ancestor D B)))) + => + empty + + (datalog parent + (? (ancestor A B))) + => + (list '(ancestor joseph3 joseph2) + '(ancestor joseph2 lucy) + '(ancestor joseph2 joseph1) + '(ancestor joseph3 lucy) + '(ancestor joseph3 joseph1)) + + (let ([x 'joseph2]) + (datalog parent + (? (parent x X)))) + => + (list '(parent joseph2 joseph1) + '(parent joseph2 lucy)) + + ) \ No newline at end of file From b565ef8d31ea1a1d638c6b6391ccaf0e0c8b5911 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 28 Jun 2010 19:58:18 -0600 Subject: [PATCH 24/28] Fixing output port original commit: b4cc683f0822b23eb25860e3376228439d743c4c --- collects/tests/datalog/main.rkt | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/collects/tests/datalog/main.rkt b/collects/tests/datalog/main.rkt index 1f4a66b..b73ad06 100644 --- a/collects/tests/datalog/main.rkt +++ b/collects/tests/datalog/main.rkt @@ -19,6 +19,7 @@ "eval.rkt") (define-runtime-path racket-mod "racket.rkt") +(define stdout (current-output-port)) (run-tests (test-suite @@ -40,4 +41,5 @@ eval-tests (test-case "Racket Interop" - (dynamic-require racket-mod #f)))) \ No newline at end of file + (parameterize ([current-output-port stdout]) + (dynamic-require racket-mod #f))))) \ No newline at end of file From fff50a1ccbba0c11521c1c5e19228994a0ba80aa Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Tue, 29 Jun 2010 11:09:07 -0600 Subject: [PATCH 25/28] Adding FFI to Datalog original commit: a6852d8f61a0b830a106911895dfa1f05bd992d8 --- collects/datalog/ast.rkt | 48 +++++++++---- collects/datalog/eval.rkt | 14 ++-- collects/datalog/pretty.rkt | 41 +++++++---- collects/datalog/private/subst.rkt | 71 ++++++++++++------- collects/datalog/private/unify.rkt | 22 ++++-- collects/datalog/private/variant.rkt | 50 +++++++++---- collects/datalog/runtime.rkt | 40 ++++++++--- collects/datalog/scribblings/datalog.scrbl | 15 ++-- collects/datalog/scribblings/racket.scrbl | 22 ++++-- collects/datalog/sexp/lang.rkt | 38 ++++++++-- collects/datalog/stx.rkt | 66 +++++++++-------- collects/tests/datalog/eval.rkt | 19 ++--- .../tests/datalog/paren-examples/add1.rkt | 10 +++ .../tests/datalog/paren-examples/add1.txt | 3 + collects/tests/datalog/paren-examples/req.rkt | 4 ++ collects/tests/datalog/paren-examples/req.txt | 1 + collects/tests/datalog/private/subst.rkt | 6 +- collects/tests/datalog/private/unify.rkt | 2 +- collects/tests/datalog/racket.rkt | 5 ++ 19 files changed, 329 insertions(+), 148 deletions(-) create mode 100644 collects/tests/datalog/paren-examples/add1.rkt create mode 100644 collects/tests/datalog/paren-examples/add1.txt create mode 100644 collects/tests/datalog/paren-examples/req.rkt create mode 100644 collects/tests/datalog/paren-examples/req.txt diff --git a/collects/datalog/ast.rkt b/collects/datalog/ast.rkt index ed41f66..4105270 100644 --- a/collects/datalog/ast.rkt +++ b/collects/datalog/ast.rkt @@ -15,9 +15,9 @@ (define-struct variable (srcloc sym) #:prefab) (define (variable-equal? v1 v2) (eq? (variable-sym v1) (variable-sym v2))) -(define-struct constant (srcloc datum) #:prefab) +(define-struct constant (srcloc value) #:prefab) (define (constant-equal? v1 v2) - (datum-equal? (constant-datum v1) (constant-datum v2))) + (equal? (constant-value v1) (constant-value v2))) (define term/c (or/c variable? constant?)) (define (term-equal? t1 t2) @@ -29,15 +29,31 @@ [else #f])) +(define (terms-equal? t1 t2) + (and (= (length t1) + (length t2)) + (andmap term-equal? t1 t2))) + (define-struct literal (srcloc predicate terms) #:prefab) (define (literal-equal? l1 l2) (and (datum-equal? (literal-predicate l1) (literal-predicate l2)) - (= (length (literal-terms l1)) - (length (literal-terms l2))) - (andmap term-equal? - (literal-terms l1) - (literal-terms l2)))) + (terms-equal? (literal-terms l1) (literal-terms l2)))) + +(define-struct external (srcloc predicate-sym predicate arg-terms ans-terms) #:prefab) +(define (external-equal? e1 e2) + (match-define (external _1 _s1 p1 ar1 an1) e1) + (match-define (external _2 _s2 p2 ar2 an2) e2) + (and (equal? p1 p2) + (terms-equal? ar1 ar2) + (terms-equal? an1 an2))) + +(define question/c (or/c literal? external?)) +(define (question-equal? q1 q2) + (or (and (literal? q1) (literal? q2) + (literal-equal? q1 q2)) + (and (external? q1) (external? q2) + (external-equal? q1 q2)))) (define-struct clause (srcloc head body) #:prefab) (define (clause-equal? c1 c2) @@ -45,13 +61,13 @@ (clause-head c2)) (= (length (clause-body c1)) (length (clause-body c2))) - (andmap literal-equal? + (andmap question-equal? (clause-body c1) (clause-body c2)))) (define-struct assertion (srcloc clause) #:prefab) (define-struct retraction (srcloc clause) #:prefab) -(define-struct query (srcloc literal) #:prefab) +(define-struct query (srcloc question) #:prefab) (define statement/c (or/c assertion? retraction? query?)) (define program/c (listof statement/c)) @@ -64,7 +80,7 @@ [sym symbol?])] [variable-equal? (variable? variable? . -> . boolean?)] [struct constant ([srcloc srcloc/c] - [datum datum/c])] + [value any/c])] [constant-equal? (constant? constant? . -> . boolean?)] [term/c contract?] [term-equal? (term/c term/c . -> . boolean?)] @@ -72,15 +88,23 @@ [predicate datum/c] [terms (listof term/c)])] [literal-equal? (literal? literal? . -> . boolean?)] + [struct external ([srcloc srcloc/c] + [predicate-sym symbol?] + [predicate procedure?] + [arg-terms (listof term/c)] + [ans-terms (listof term/c)])] + [external-equal? (external? external? . -> . boolean?)] + [question/c contract?] + [question-equal? (question/c question/c . -> . boolean?)] [struct clause ([srcloc srcloc/c] [head literal?] - [body (listof literal?)])] + [body (listof question/c)])] [clause-equal? (clause? clause? . -> . boolean?)] [struct assertion ([srcloc srcloc/c] [clause clause?])] [struct retraction ([srcloc srcloc/c] [clause clause?])] [struct query ([srcloc srcloc/c] - [literal literal?])] + [question question/c])] [statement/c contract?] [program/c contract?]) diff --git a/collects/datalog/eval.rkt b/collects/datalog/eval.rkt index 82f6e67..ac1e51f 100644 --- a/collects/datalog/eval.rkt +++ b/collects/datalog/eval.rkt @@ -14,9 +14,9 @@ "Unsafe clause in assertion" (datum->syntax #f (format-statement s) (assertion-srcloc s)))))) -(define (print-literals ls) +(define (print-questions ls) (displayln - (format-literals ls))) + (format-questions ls))) (define (eval-program p) (for-each eval-top-level-statement p)) @@ -24,7 +24,7 @@ (define (eval-top-level-statement s) (define v (eval-statement s)) (unless (void? v) - (print-literals v))) + (print-questions v))) (define (eval-statement s) (cond @@ -33,7 +33,7 @@ [(retraction? s) (retract! (current-theory) (retraction-clause s))] [(query? s) - (prove (current-theory) (query-literal s))])) + (prove (current-theory) (query-question s))])) (define (eval-program/fresh p) (let loop ([thy (make-immutable-theory)] @@ -48,14 +48,14 @@ [(retraction? s) (retract thy (retraction-clause s))] [(query? s) - (print-literals (prove thy (query-literal s))) + (print-questions (prove thy (query-question s))) thy]) (rest p)))))) (provide/contract [current-theory (parameter/c mutable-theory/c)] - [print-literals ((listof literal?) . -> . void)] + [print-questions ((listof question/c) . -> . void)] [eval-program (program/c . -> . void)] [eval-top-level-statement (statement/c . -> . void)] - [eval-statement (statement/c . -> . (or/c void (listof literal?)))] + [eval-statement (statement/c . -> . (or/c void (listof question/c)))] [eval-program/fresh (program/c . -> . immutable-theory/c)]) \ No newline at end of file diff --git a/collects/datalog/pretty.rkt b/collects/datalog/pretty.rkt index e58d7d9..39f92f6 100644 --- a/collects/datalog/pretty.rkt +++ b/collects/datalog/pretty.rkt @@ -4,19 +4,19 @@ (define (format-datum s) (cond - [(string? s) - (text (format "~S" s))] [(symbol? s) - (text (symbol->string s))])) + (text (symbol->string s))] + [else + (text (format "~S" s))])) (define (format-variable v) (format-datum (variable-sym v))) (define (format-constant c) - (format-datum (constant-datum c))) -(define (format-term t) - (cond - [(variable? t) + (format-datum (constant-value c))) +(define format-term + (match-lambda + [(? variable? t) (format-variable t)] - [(constant? t) + [(? constant? t) (format-constant t)])) (define (format-literal l) (match l @@ -29,10 +29,27 @@ lparen (v-concat/s (apply-infix ", " (map format-term terms))) rparen)])) -(define (format-literals ls) +(define format-external + (match-lambda + [(external _ pred-sym pred args anss) + (h-append (format-datum pred-sym) + lparen + (v-concat/s (apply-infix ", " (map format-term args))) + rparen + (text " = ") + lparen + (v-concat/s (apply-infix ", " (map format-term anss))) + rparen)])) +(define format-question + (match-lambda + [(? literal? l) + (format-literal l)] + [(? external? e) + (format-external e)])) +(define (format-questions ls) (v-concat (append (map (lambda (l) - (format-assertion (make-assertion #f (make-clause #f l (list))))) + (h-append (format-question l) dot)) ls) (list line)))) (define (format-clause c) @@ -49,7 +66,7 @@ (h-append (format-clause (retraction-clause r)) (char #\~))) (define (format-query q) - (h-append (format-literal (query-literal q)) + (h-append (format-question (query-question q)) (char #\?))) (define (format-statement s) @@ -66,7 +83,7 @@ [format-constant (constant? . -> . doc?)] [format-term (term/c . -> . doc?)] [format-literal (literal? . -> . doc?)] - [format-literals ((listof literal?) . -> . doc?)] + [format-questions ((listof question/c) . -> . doc?)] [format-clause (clause? . -> . doc?)] [format-assertion (assertion? . -> . doc?)] [format-retraction (retraction? . -> . doc?)] diff --git a/collects/datalog/private/subst.rkt b/collects/datalog/private/subst.rkt index 3ec3581..646e66d 100644 --- a/collects/datalog/private/subst.rkt +++ b/collects/datalog/private/subst.rkt @@ -9,32 +9,52 @@ [_ t])) +(define (subst-terms env ts) + (map (curry subst-term env) ts)) + (define (subst-literal env lit) - (make-literal (literal-srcloc lit) - (literal-predicate lit) - (map (lambda (t) (subst-term env t)) - (literal-terms lit)))) + (struct-copy + literal lit + [terms + (subst-terms env (literal-terms lit))])) + +(define (subst-external env ext) + (struct-copy + external ext + [arg-terms + (subst-terms env (external-arg-terms ext))] + [ans-terms + (subst-terms env (external-ans-terms ext))])) + +(define (subst-question env q) + (match q + [(? literal?) (subst-literal env q)] + [(? external?) (subst-external env q)])) (define (subst-clause env c) - (make-clause (clause-srcloc c) - (subst-literal env (clause-head c)) - (map (lambda (l) (subst-literal env l)) - (clause-body c)))) + (clause (clause-srcloc c) + (subst-literal env (clause-head c)) + (map (curry subst-question env) + (clause-body c)))) -(define (shuffle env lit) - (match lit - [(struct literal (_ pred terms)) - (let loop ([env env] - [terms terms]) - (match terms - [(list) - env] - [(list-rest (struct constant (_ value)) terms) - (loop env terms)] - [(list-rest (struct variable (srcloc var)) terms) - (if (lookup env var) - (loop env terms) - (loop (extend env var (make-variable srcloc (gensym var))) terms))]))])) +(define (shuffle-terms env terms) + (match terms + [(list) + env] + [(list-rest (constant _ value) terms) + (shuffle-terms env terms)] + [(list-rest (variable srcloc var) terms) + (if (lookup env var) + (shuffle-terms env terms) + (shuffle-terms (extend env var (make-variable srcloc (gensym var))) + terms))])) + +(define (shuffle env q) + (match q + [(external _ _ pred arg-terms ans-terms) + (shuffle-terms env (append arg-terms ans-terms))] + [(literal _ pred terms) + (shuffle-terms env terms)])) (define (rename-clause c) (define env @@ -44,11 +64,12 @@ (clause-body c))) (subst-clause env c)) -(define (rename-literal lit) - (subst-literal (shuffle (empty-env) lit) lit)) +(define (rename-question q) + (subst-question (shuffle (empty-env) q) q)) (provide/contract + [subst-terms (env/c (listof term/c) . -> . (listof term/c))] [subst-term (env/c term/c . -> . term/c)] [subst-clause (env/c clause? . -> . clause?)] [rename-clause (clause? . -> . clause?)] - [rename-literal (literal? . -> . literal?)]) \ No newline at end of file + [rename-question (question/c . -> . question/c)]) \ No newline at end of file diff --git a/collects/datalog/private/unify.rkt b/collects/datalog/private/unify.rkt index 8943e27..fabbdf2 100644 --- a/collects/datalog/private/unify.rkt +++ b/collects/datalog/private/unify.rkt @@ -38,12 +38,22 @@ [env (unify-terms env (rest ts1) (rest ts2))])))) (define (unify l1 l2) - (and (datum-equal? (literal-predicate l1) - (literal-predicate l2)) - (unify-terms (empty-env) - (literal-terms l1) - (literal-terms l2)))) + (or (and (literal? l1) (literal? l2) + (datum-equal? (literal-predicate l1) + (literal-predicate l2)) + (unify-terms (empty-env) + (literal-terms l1) + (literal-terms l2))) + (and (external? l1) (external? l2) + (equal? (external-predicate l1) + (external-predicate l2)) + (unify-terms (empty-env) + (append (external-arg-terms l1) + (external-ans-terms l1)) + (append (external-arg-terms l2) + (external-ans-terms l2)))))) (provide/contract - [unify (literal? literal? . -> . (or/c false/c env/c))] + [unify (question/c question/c . -> . (or/c false/c env/c))] + [unify-terms (env/c (listof term/c) (listof term/c) . -> . (or/c false/c env/c))] [unify-term (env/c term/c term/c . -> . (or/c false/c env/c))]) \ No newline at end of file diff --git a/collects/datalog/private/variant.rkt b/collects/datalog/private/variant.rkt index e28981d..76b77e4 100644 --- a/collects/datalog/private/variant.rkt +++ b/collects/datalog/private/variant.rkt @@ -35,13 +35,25 @@ [_ #f])) (define (variant? l1 l2) - (and - (datum-equal? (literal-predicate l1) - (literal-predicate l2)) - (variant-terms - (empty-env) (empty-env) - (literal-terms l1) - (literal-terms l2)))) + (or + (and (literal? l1) (literal? l2) + (datum-equal? (literal-predicate l1) + (literal-predicate l2)) + (variant-terms + (empty-env) (empty-env) + (literal-terms l1) + (literal-terms l2))) + (and (external? l1) (external? l2) + (equal? (external-predicate l1) + (external-predicate l2)) + (variant-terms + (empty-env) (empty-env) + (external-arg-terms l1) + (external-arg-terms l2)) + (variant-terms + (empty-env) (empty-env) + (external-ans-terms l1) + (external-ans-terms l2))))) (define (mem-literal lit ls) (ormap (lambda (l) (variant? lit l)) ls)) @@ -52,11 +64,21 @@ [(variable? t) 101] [(constant? t) - (recur-hash (constant-datum t))])) -(define ((mk-literal-hash recur-hash) l) - (let loop ([code (recur-hash (literal-predicate l))] + (recur-hash (constant-value t))])) +(define ((mk-literal-hash recur-hash) q) + (define-values + (code terms) + (match q + [(? literal? l) + (values (recur-hash (literal-predicate l)) + (literal-terms l))] + [(? external? e) + (values (recur-hash (external-predicate e)) + (append (external-arg-terms e) + (external-ans-terms e)))])) + (let loop ([code code] [i 0] - [terms (literal-terms l)]) + [terms terms]) (if (empty? terms) code (loop (+ code (term-hash (first terms) recur-hash) (* i -7)) @@ -78,6 +100,6 @@ (provide/contract [literal-tbl/c contract?] [make-literal-tbl (-> literal-tbl/c)] - [literal-tbl-find (literal-tbl/c literal? . -> . (or/c false/c any/c))] - [literal-tbl-replace! (literal-tbl/c literal? any/c . -> . void)] - [mem-literal (literal? (listof literal?) . -> . boolean?)]) \ No newline at end of file + [literal-tbl-find (literal-tbl/c question/c . -> . (or/c false/c any/c))] + [literal-tbl-replace! (literal-tbl/c question/c any/c . -> . void)] + [mem-literal (question/c (listof question/c) . -> . boolean?)]) \ No newline at end of file diff --git a/collects/datalog/runtime.rkt b/collects/datalog/runtime.rkt index a7a0fea..f0715fd 100644 --- a/collects/datalog/runtime.rkt +++ b/collects/datalog/runtime.rkt @@ -11,7 +11,12 @@ (andmap (lambda (v) (ormap (lambda (l) (ormap (lambda (t) (term-equal? t v)) - (literal-terms l))) + (cond + [(literal? l) + (literal-terms l)] + [(external? l) + (append (external-arg-terms l) + (external-ans-terms l))]))) (clause-body c))) head-vars)) @@ -52,20 +57,20 @@ (hash-ref thy (literal-key lit) empty)) (define-struct subgoal - (literal + (question [facts #:mutable] [waiters #:mutable])) -(define (resolve c lit) +(define (resolve c q) (define body (clause-body c)) (and (not (empty? body)) (cond - [(unify (first body) (rename-literal lit)) + [(unify (first body) (rename-question q)) => (lambda (env) (subst-clause env (make-clause (clause-srcloc c) (clause-head c) (rest body))))] [else #f]))) -(define (prove thy lit) +(define (prove thy q) (define subgoals (make-literal-tbl)) (define (fact! sg lit) (unless (mem-literal lit (subgoal-facts sg)) @@ -100,12 +105,25 @@ (define renamed (rename-clause clause)) (define selected (clause-head renamed)) (cond - [(unify (subgoal-literal sg) selected) + [(unify (subgoal-question sg) selected) => (lambda (env) (add-clause! sg (subst-clause env renamed)))])) - (get thy (subgoal-literal sg)))) + (get thy (subgoal-question sg)))) (define (search! sg) - (match (subgoal-literal sg) + (match (subgoal-question sg) + [(external srcloc pred-sym pred args anss) + (and (andmap constant? args) + (call-with-values + (λ () + (apply pred (map constant-value args))) + (λ resolved-vals + (define resolved-anss + (map (curry constant #f) + resolved-vals)) + (cond + [(unify-terms (empty-env) anss resolved-anss) + => (λ (env) + (fact! sg (external srcloc pred-sym pred args (subst-terms env anss))))]))))] [(struct literal (srcloc '= (list a b))) (define (equal-test a b) (when (term-equal? a b) @@ -116,8 +134,8 @@ [else (equal-test a b)])] [_ (search-theory! sg)])) - (define sg (make-subgoal lit empty empty)) - (literal-tbl-replace! subgoals lit sg) + (define sg (make-subgoal q empty empty)) + (literal-tbl-replace! subgoals q sg) (search! sg) (subgoal-facts sg)) @@ -133,4 +151,4 @@ [retract (immutable-theory/c clause? . -> . immutable-theory/c)] [assume! (mutable-theory/c safe-clause? . -> . void)] [retract! (mutable-theory/c clause? . -> . void)] - [prove (theory/c literal? . -> . (listof literal?))]) \ No newline at end of file + [prove (theory/c question/c . -> . (listof question/c))]) \ No newline at end of file diff --git a/collects/datalog/scribblings/datalog.scrbl b/collects/datalog/scribblings/datalog.scrbl index 367feb9..cef4391 100644 --- a/collects/datalog/scribblings/datalog.scrbl +++ b/collects/datalog/scribblings/datalog.scrbl @@ -130,13 +130,14 @@ The Datalog REPL accepts new statements that are executed as if they were in the @include-section["tutorial.scrbl"] @section{Parenthetical Datalog Module Language} -@(require (for-label datalog)) +@(require (for-label datalog + racket)) @defmodulelang[datalog/sexp] -The semantics of this language is the same as the normal Datalog language, except it uses a parenthetical syntax. +The semantics of this language is the same as the normal Datalog language, except it uses the parenthetical syntax described in @secref{interop}. -Literals are represented as S-expressions with non-capitalized identifiers for constant symbols, strings for constant strings, and capitalized identifiers for variable symbols. Top-level identifiers and strings are not otherwise allowed in the program. +All identifiers in @racketmodname[racket/base] are available for use as predicate symbols or constant values. Top-level identifiers and datums are not otherwise allowed in the program. The program may contain @racket[require] expressions. The following is a program: @racketmod[datalog/sexp @@ -152,7 +153,13 @@ The following is a program: (path Z Y))) (? (path X Y))] -The Parenthetical Datalog REPL accepts new statements that are executed as if they were in the original program text. +This is also a program: +@racketmod[datalog/sexp +(require racket/math) + +(? (sqr 4 :- X))] + +The Parenthetical Datalog REPL accepts new statements that are executed as if they were in the original program text, except @racket[require] is not allowed. @include-section["racket.scrbl"] diff --git a/collects/datalog/scribblings/racket.scrbl b/collects/datalog/scribblings/racket.scrbl index 195a7a1..57e1ea3 100644 --- a/collects/datalog/scribblings/racket.scrbl +++ b/collects/datalog/scribblings/racket.scrbl @@ -8,7 +8,7 @@ "../main.rkt") "utils.rkt") -@title{Racket Interoperability} +@title[#:tag "interop"]{Racket Interoperability} @defmodule[datalog] @@ -45,7 +45,10 @@ The Datalog database can be directly used by Racket programs through this API. (let ([x 'joseph2]) (datalog family - (? (parent x X))))] + (? (parent x X)))) + + (datalog family + (? (add1 1 :- X)))] @defthing[mutable-theory/c contract?]{ A contract for Datalog theories. } @@ -58,11 +61,18 @@ The Datalog database can be directly used by Racket programs through this API. @defform[(datalog! thy-expr stmt ...) #:contracts ([thy-expr mutable-theory/c])]{ Executes the statements on the theory given by @racket[thy-expr]. Prints the answers to every query in the list of statements. Returns @racket[(void)]. } - -Literals are represented as S-expressions with non-capitalized identifiers for constant symbols, strings for constant strings, and capitalized identifiers for variable symbols. Bound identifiers are treated as constants; they must evaluate to either a symbol or string. + +Statements are either assertions, retractions, or queries. @defform[(! clause)]{ Asserts the clause. } @defform[(~ clause)]{ Retracts the literal. } -@defform[(? literal)]{ Queries the literal and prints the result literals. } -@defform[(:- literal literal ...)]{ A conditional clause. } \ No newline at end of file +@defform[(:- literal question ...)]{ A conditional clause. } + +@defform[(? question)]{ Queries the literal and prints the result literals. } + +Questions are either literals or external queries. +Literals are represented as @racket[identifier] or @racket[(identifier term ...)]. +Questions are represented as @racket[(identifier term ... :- term ...)], where @racket[identifier] is bound to a procedure that when given the first set of terms as arguments returns the second set of terms as values. +A term is either a non-capitalized identifiers for a constant symbol, a Racket datum for a constant datum, or a capitalized identifier for a variable symbol. Bound identifiers in terms are treated as datums. + diff --git a/collects/datalog/sexp/lang.rkt b/collects/datalog/sexp/lang.rkt index addccfb..4a61374 100644 --- a/collects/datalog/sexp/lang.rkt +++ b/collects/datalog/sexp/lang.rkt @@ -1,15 +1,36 @@ -#lang racket -(require (for-syntax syntax/parse) +#lang racket/base +(require (for-syntax syntax/parse + racket/list + racket/base) datalog/stx datalog/runtime) (define lang-theory (make-theory)) -(define-syntax module-begin - (syntax-rules () - [(_ stmt ...) - (#%module-begin - (datalog! lang-theory stmt ...))])) +(define-for-syntax (partition-requires es) + (define-values (rs stmts) + (partition + (λ (e-stx) + (syntax-parse + e-stx + #:literals (require) + [(require . r) + #t] + [_ + #f])) + (syntax->list es))) + (list rs stmts)) + +(define-syntax (module-begin stx) + (syntax-case stx () + [(_ . es) + (with-syntax ([((requires ...) + (stmt ...)) + (partition-requires #'es)]) + (syntax/loc stx + (#%module-begin + requires ... + (datalog! lang-theory stmt ...))))])) (define-syntax top-interaction (syntax-rules () @@ -18,4 +39,7 @@ (provide (rename-out [top-interaction #%top-interaction] [module-begin #%module-begin]) + (except-out (all-from-out racket/base) + #%top-interaction + #%module-begin) ! ~ ? :-) \ No newline at end of file diff --git a/collects/datalog/stx.rkt b/collects/datalog/stx.rkt index 9cff0b9..fdff139 100644 --- a/collects/datalog/stx.rkt +++ b/collects/datalog/stx.rkt @@ -21,6 +21,10 @@ (define literal->sexp (match-lambda + [(external _ pred-sym _ args anss) + `(,pred-sym ,@(map term->datum args) + :- + ,@(map term->datum anss))] [(literal _ pred ts) (list* pred (map term->datum ts))])) @@ -49,57 +53,63 @@ (syntax-parse stx #:literals (! ~ ?) - [(_ (! c)) - (quasisyntax/loc stx - (assertion #'#,stx (datalog-clause c)))] - [(_ (~ c)) - (quasisyntax/loc stx - (retraction #'#,stx (datalog-clause c)))] - [(_ (? l)) - (quasisyntax/loc stx - (query #'#,stx (datalog-literal l)))])) + [(_ (~and tstx (! c))) + (quasisyntax/loc #'tstx + (assertion #'#,#'tstx (datalog-clause c)))] + [(_ (~and tstx (~ c))) + (quasisyntax/loc #'tstx + (retraction #'#,#'tstx (datalog-clause c)))] + [(_ (~and tstx (? l))) + (quasisyntax/loc #'tstx + (query #'#,#'tstx (datalog-literal l)))])) (define-syntax (datalog-clause stx) (syntax-parse stx #:literals (:-) - [(_ (:- head body ...)) - (quasisyntax/loc stx - (clause #'#,stx (datalog-literal head) + [(_ (~and tstx (:- head body ...))) + (quasisyntax/loc #'tstx + (clause #'#,#'tstx (datalog-literal head) (list (datalog-literal body) ...)))] [(_ e) - (quasisyntax/loc stx - (clause #'#,stx (datalog-literal e) empty))])) + (quasisyntax/loc #'e + (clause #'#,#'e (datalog-literal e) empty))])) (define-syntax (datalog-literal stx) (syntax-parse stx + #:literals (:-) [(_ sym:id) - (quasisyntax/loc stx - (literal #'#,stx 'sym empty))] - [(_ (sym:id e ...)) - (quasisyntax/loc stx - (literal #'#,stx 'sym + (quasisyntax/loc #'sym + (literal #'#,#'sym 'sym empty))] + [(_ (~and tstx (sym:id arg ... :- ans ...))) + (quasisyntax/loc #'tstx + (external #'#,#'tstx 'sym sym + (list (datalog-term arg) ...) + (list (datalog-term ans) ...)))] + [(_ (~and tstx (sym:id e ...))) + (quasisyntax/loc #'tstx + (literal #'#,#'tstx 'sym (list (datalog-term e) ...)))])) (define-syntax (datalog-term stx) (syntax-parse stx - [(_ sym:str) - (quasisyntax/loc stx - (constant #'#,stx 'sym))] [(_ sym:id) (cond [(identifier-binding #'sym 0) - (quasisyntax/loc stx - (constant #'#,stx sym))] + (quasisyntax/loc #'sym + (constant #'#,#'sym sym))] [(char-upper-case? (string-ref (symbol->string (syntax->datum #'sym)) 0)) - (quasisyntax/loc stx - (variable #'#,stx 'sym))] + (quasisyntax/loc #'sym + (variable #'#,#'sym 'sym))] [else - (quasisyntax/loc stx - (constant #'#,stx 'sym))])])) + (quasisyntax/loc #'sym + (constant #'#,#'sym 'sym))])] + [(_ sym:expr) + (quasisyntax/loc #'sym + (constant #'#,#'sym sym))])) (provide datalog datalog! :- ! ~ ?) diff --git a/collects/tests/datalog/eval.rkt b/collects/tests/datalog/eval.rkt index 8864bd6..3611fd5 100644 --- a/collects/tests/datalog/eval.rkt +++ b/collects/tests/datalog/eval.rkt @@ -22,22 +22,17 @@ port->lines)) (filter (lambda (l) (not (string=? l ""))) - (file->lines test-txt)) - )) + (file->lines test-txt)))) + + (define (test-files d) + (for ([f (in-list (directory-list d))] + #:when (regexp-match #rx"rkt$" (path->bytes f))) + (test-example (path->string (path-replace-suffix f #""))))) (test-suite (path->string examples-dir) - (test-example "ancestor") - (test-example "bidipath") - (test-example "laps") - (test-example "long") - (test-example "path") - (test-example "pq") - (test-example "revpath") - (test-example "says") - (test-example "true") - (test-example "tutorial"))) + (test-files examples-dir))) (define eval-tests (test-suite diff --git a/collects/tests/datalog/paren-examples/add1.rkt b/collects/tests/datalog/paren-examples/add1.rkt new file mode 100644 index 0000000..f89b1b0 --- /dev/null +++ b/collects/tests/datalog/paren-examples/add1.rkt @@ -0,0 +1,10 @@ +#lang datalog/sexp +(? (add1 2 :- X)) + +(! (:- (add2 X Y) + (add1 X :- Z) + (add1 Z :- Y))) + +(? (add2 1 3)) + +(? (add1 X :- 1)) \ No newline at end of file diff --git a/collects/tests/datalog/paren-examples/add1.txt b/collects/tests/datalog/paren-examples/add1.txt new file mode 100644 index 0000000..dc6a141 --- /dev/null +++ b/collects/tests/datalog/paren-examples/add1.txt @@ -0,0 +1,3 @@ +add1(2) = (3). + +add2(1, 3). diff --git a/collects/tests/datalog/paren-examples/req.rkt b/collects/tests/datalog/paren-examples/req.rkt new file mode 100644 index 0000000..c7cfb8d --- /dev/null +++ b/collects/tests/datalog/paren-examples/req.rkt @@ -0,0 +1,4 @@ +#lang datalog/sexp +(require racket/math) + +(? (sqr 4 :- X)) \ No newline at end of file diff --git a/collects/tests/datalog/paren-examples/req.txt b/collects/tests/datalog/paren-examples/req.txt new file mode 100644 index 0000000..8cc5574 --- /dev/null +++ b/collects/tests/datalog/paren-examples/req.txt @@ -0,0 +1 @@ +sqr(4) = (16). diff --git a/collects/tests/datalog/private/subst.rkt b/collects/tests/datalog/private/subst.rkt index 2871f40..2dc0a48 100644 --- a/collects/tests/datalog/private/subst.rkt +++ b/collects/tests/datalog/private/subst.rkt @@ -85,14 +85,14 @@ 'v1)))) (test-suite - "rename-literal" - (test-equal? "l" (rename-literal (make-literal #f 'lit (list (make-constant #f 'v1)))) + "rename-question" + (test-equal? "l" (rename-question (make-literal #f 'lit (list (make-constant #f 'v1)))) (make-literal #f 'lit (list (make-constant #f 'v1)))) (test-not-false "l" (gensym-var? (first (literal-terms - (rename-literal (make-literal #f 'lit (list (make-variable #f 'v1))))))))) + (rename-question (make-literal #f 'lit (list (make-variable #f 'v1))))))))) (test-suite "rename-clause" diff --git a/collects/tests/datalog/private/unify.rkt b/collects/tests/datalog/private/unify.rkt index 2ea94e6..688c381 100644 --- a/collects/tests/datalog/private/unify.rkt +++ b/collects/tests/datalog/private/unify.rkt @@ -3,7 +3,7 @@ datalog/ast datalog/private/env datalog/private/unify) -(require/expose datalog/private/unify (chase unify-terms)) +(require/expose datalog/private/unify (chase)) (provide unify-tests) diff --git a/collects/tests/datalog/racket.rkt b/collects/tests/datalog/racket.rkt index 39a6716..439aa74 100644 --- a/collects/tests/datalog/racket.rkt +++ b/collects/tests/datalog/racket.rkt @@ -54,4 +54,9 @@ (list '(parent joseph2 joseph1) '(parent joseph2 lucy)) + (datalog parent + (? (add1 1 :- X))) + => + (list '(add1 1 :- 2)) + ) \ No newline at end of file From ed27738882e33522830602c69bb666b54ffe17b7 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Tue, 29 Jun 2010 13:18:04 -0600 Subject: [PATCH 26/28] Fixing tests, adding provide, clarifying names original commit: 0062a4eb23383f0c2303c7308fee62a421bb26e3 --- collects/datalog/parse.rkt | 30 ------------------- collects/datalog/private/lex.rkt | 16 ---------- collects/datalog/scribblings/datalog.scrbl | 3 +- collects/datalog/sexp/lang.rkt | 19 +++++++----- .../tests/datalog/paren-examples/path.txt | 4 +-- collects/tests/datalog/racket.rkt | 22 ++++++++++++++ 6 files changed, 38 insertions(+), 56 deletions(-) diff --git a/collects/datalog/parse.rkt b/collects/datalog/parse.rkt index f846055..83e5249 100644 --- a/collects/datalog/parse.rkt +++ b/collects/datalog/parse.rkt @@ -4,36 +4,6 @@ "private/lex.rkt" "ast.rkt") -#| -5.1 Literals - -A literal, is a predicate symbol followed by an optional parenthesized list of comma separated terms. A predicate symbol is either an identifier or a string. A term is either a variable or a constant. As with predicate symbols, a constant is either an identifier or a string. The following are literals: - - parent(john, douglas) - zero-arity-literal - aBcD(-0, "\n\FF") - "="(3,3) - ""(-0-0-0,&&&,***,"\00") -5.2 Clauses - -A clause is a head literal followed by an optional body. A body is a comma separated list of literals. A clause without a body is called a fact, and a rule when it has one. The punctuation `:-' separates the head of a rule from its body. A clause is safe if every variable in its head occurs in some literal in its body. The following are safe clauses: - - parent(john, douglas) - ancestor(A, B) :- - parent(A, B) - ancestor(A, B) :- - parent(A, C), - ancestor(C, B) -5.3 Programs - -A Datalog reader consumes a Datalog program. A program is a sequence of zero or more statements, followed by an optional query. A statement is an assertion or a retraction. An assertion is a clause followed by a period, and it adds the clause to the database if it is safe. A retraction is a clause followed by a tilde, and it removes the clause from the database. A query is a literal followed by a question mark. The effect of reading a Datalog program is to modify the database as directed by its statements, and then to return the literal designated as the query. If no query is specified, a reader returns a literal know to have no answers. The following is a program: - - edge(a, b). edge(b, c). edge(c, d). edge(d, a). - path(X, Y) :- edge(X, Y). - path(X, Y) :- edge(X, Z), path(Z, Y). - path(X, Y)? -|# - (define current-source-name (make-parameter #f)) (define (make-srcloc start-pos end-pos) diff --git a/collects/datalog/private/lex.rkt b/collects/datalog/private/lex.rkt index 459752d..58b9f49 100644 --- a/collects/datalog/private/lex.rkt +++ b/collects/datalog/private/lex.rkt @@ -2,22 +2,6 @@ (require parser-tools/lex (prefix-in : parser-tools/lex-sre)) -#| -5 Syntax - -In Datalog input, whitespace characters are ignored except when they separate adjacent tokens or when they occur in strings. Comments are also considered to be whitespace. The character `%' introduces a comment, which extends to the next line break. Comments do not occur inside strings. - -The characters in Datalog input are collected into tokens according to the rules that follow. There are four classes of tokens: punctuations, variables, identifiers, and strings. The punctuation tokens are: `(', `,', `)', `=', `:-', `.', `~', `?', and `"'. - -A variable is a sequence of Latin capital and small letters, digits, and the underscore character. A variable must begin with a Latin capital letter. - -An identifier is a sequence of printing characters that does not contain any of the following characters: `(', `,', `)', `=', `:', `.', `~', `?', `"', `%', and space. An identifier must not begin with a Latin capital letter. Note that the characters that start punctuation are forbidden in identifiers, but the hyphen character is allowed. - -A string is a sequence of characters enclosed in double quotes. Characters other than double quote, newline, and backslash may be directly included in a string. The remaining characters may be specified using escape characters, `\"', `\n', and `\\' respectively. - -Other escape characters can be used to improve the readability of the input. If a string is too long to fit conveniently on one line, all but the final line containing the string can be ended with a backslash character, and each backslash newline pair is ignored. The character escape codes from the C programming language are allowed—`\a', `\b', `\f', `\n', `\r', `\t', `\v', `\'', and `\?'. The numeric escape codes consist of exactly two uppercase hex digits. Thus the ASCII character newline is `\0A', and zero is `\00'. -|# - (define-tokens dtokens (VARIABLE IDENTIFIER STRING)) (define-empty-tokens dpunct (LPAREN COMMA RPAREN TSTILE DOT EQUAL TILDE QMARK EOF)) (define-lex-abbrev line-break #\newline) diff --git a/collects/datalog/scribblings/datalog.scrbl b/collects/datalog/scribblings/datalog.scrbl index cef4391..6942712 100644 --- a/collects/datalog/scribblings/datalog.scrbl +++ b/collects/datalog/scribblings/datalog.scrbl @@ -30,7 +30,7 @@ In Datalog input, whitespace characters are ignored except when they separate ad Comments are also considered to be whitespace. The character @litchar["%"] introduces a comment, which extends to the next line break. Comments do not occur inside strings. -A variable is a sequence of Latin capital and small letters, digits, and the underscore character. A variable must begin with a Latin capital letter. +A variable is a sequence of Unicode "Uppercase" and "Lowercase" letters, digits, and the underscore character. A variable must begin with a Unicode "Uppercase" letter. An identifier is a sequence of printing characters that does not contain any of the following characters: @litchar["("], @litchar["`"], @litchar["'"], @litchar[")"], @litchar["="], @litchar[":"], @litchar["."], @litchar["~"], @litchar["?"], @litchar["\""], @litchar["%"], and space. @@ -113,6 +113,7 @@ The following BNF describes the syntax of Datalog. The effect of running a Datalog program is to modify the database as directed by its statements, and then to return the literals designated by the query. +The modified database is provided as @racket[theory]. The following is a program: diff --git a/collects/datalog/sexp/lang.rkt b/collects/datalog/sexp/lang.rkt index 4a61374..32a692b 100644 --- a/collects/datalog/sexp/lang.rkt +++ b/collects/datalog/sexp/lang.rkt @@ -2,11 +2,10 @@ (require (for-syntax syntax/parse racket/list racket/base) + racket/contract datalog/stx datalog/runtime) -(define lang-theory (make-theory)) - (define-for-syntax (partition-requires es) (define-values (rs stmts) (partition @@ -24,18 +23,24 @@ (define-syntax (module-begin stx) (syntax-case stx () [(_ . es) - (with-syntax ([((requires ...) + (with-syntax ([theory (datum->syntax #'es 'theory)] + [((requires ...) (stmt ...)) (partition-requires #'es)]) (syntax/loc stx (#%module-begin requires ... - (datalog! lang-theory stmt ...))))])) + (define theory (make-theory)) + (datalog! theory stmt ...) + (provide/contract + [theory mutable-theory/c]))))])) -(define-syntax top-interaction - (syntax-rules () +(define-syntax (top-interaction stx) + (syntax-case stx () [(_ . stmt) - (datalog! lang-theory stmt)])) + (with-syntax ([theory (datum->syntax #'stmt 'theory)]) + (syntax/loc stx + (datalog! theory stmt)))])) (provide (rename-out [top-interaction #%top-interaction] [module-begin #%module-begin]) diff --git a/collects/tests/datalog/paren-examples/path.txt b/collects/tests/datalog/paren-examples/path.txt index cfe9dae..9319f8c 100644 --- a/collects/tests/datalog/paren-examples/path.txt +++ b/collects/tests/datalog/paren-examples/path.txt @@ -7,9 +7,9 @@ path(b, d). path(b, c). path(b, b). path(c, a). -path(c, b). -path(c, c). path(c, d). +path(c, c). +path(c, b). path(d, b). path(d, c). path(d, d). diff --git a/collects/tests/datalog/racket.rkt b/collects/tests/datalog/racket.rkt index 439aa74..a253658 100644 --- a/collects/tests/datalog/racket.rkt +++ b/collects/tests/datalog/racket.rkt @@ -59,4 +59,26 @@ => (list '(add1 1 :- 2)) + (local [(local-require tests/datalog/examples/ancestor)] + (datalog theory + (? (ancestor A B)))) + => + '((ancestor ebbon bob) + (ancestor bob john) + (ancestor john douglas) + (ancestor bob douglas) + (ancestor ebbon john) + (ancestor ebbon douglas)) + + (local [(local-require tests/datalog/paren-examples/ancestor)] + (datalog theory + (? (ancestor A B)))) + => + '((ancestor ebbon bob) + (ancestor bob john) + (ancestor john douglas) + (ancestor bob douglas) + (ancestor ebbon john) + (ancestor ebbon douglas)) + ) \ No newline at end of file From f3127aa2c19d55fdce8aa222fe32081c805cb233 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Tue, 29 Jun 2010 16:02:42 -0600 Subject: [PATCH 27/28] Fix documentation and add warning voice original commit: 4e932f6c6b671b4a780222957b4420d1c2c6e63f --- collects/datalog/scribblings/racket.scrbl | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/collects/datalog/scribblings/racket.scrbl b/collects/datalog/scribblings/racket.scrbl index 57e1ea3..f4e3ed4 100644 --- a/collects/datalog/scribblings/racket.scrbl +++ b/collects/datalog/scribblings/racket.scrbl @@ -73,6 +73,14 @@ Statements are either assertions, retractions, or queries. Questions are either literals or external queries. Literals are represented as @racket[identifier] or @racket[(identifier term ...)]. -Questions are represented as @racket[(identifier term ... :- term ...)], where @racket[identifier] is bound to a procedure that when given the first set of terms as arguments returns the second set of terms as values. +External queries are represented as @racket[(identifier term ... :- term ...)], where @racket[identifier] is bound to a procedure that when given the first set of terms as arguments returns the second set of terms as values. A term is either a non-capitalized identifiers for a constant symbol, a Racket datum for a constant datum, or a capitalized identifier for a variable symbol. Bound identifiers in terms are treated as datums. +External queries invalidate Datalog's guaranteed termination. For example, this program does not terminate: +@racketblock[ + (datalog (make-theory) + (! (:- (loop X) + (add1 X :- Z) + (loop Z))) + (? (loop 1))) + ] \ No newline at end of file From 0a86976eb13bea90f254b8caf42d17ebcc0aeba0 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Wed, 30 Jun 2010 10:30:55 -0600 Subject: [PATCH 28/28] Switch to using substitutions in returns and remove old parts of the interface original commit: 06844073c7eb71d597a4d4a2ea8594725b982dd7 --- collects/datalog/eval.rkt | 24 ++--------- collects/datalog/main.rkt | 2 +- collects/datalog/runtime.rkt | 20 +++------ collects/datalog/scribblings/racket.scrbl | 8 ++-- collects/datalog/sexp/lang.rkt | 2 +- collects/datalog/stx.rkt | 52 ++++++++++++++++++++--- collects/tests/datalog/racket.rkt | 48 ++++++++++----------- collects/tests/datalog/runtime.rkt | 17 ++------ 8 files changed, 87 insertions(+), 86 deletions(-) diff --git a/collects/datalog/eval.rkt b/collects/datalog/eval.rkt index ac1e51f..2bea9d0 100644 --- a/collects/datalog/eval.rkt +++ b/collects/datalog/eval.rkt @@ -4,7 +4,7 @@ "pretty.rkt" "runtime.rkt") -(define current-theory (make-parameter (make-mutable-theory))) +(define current-theory (make-parameter (make-theory))) (define (assume-if-safe assume thy s) (let ([c (assertion-clause s)]) @@ -35,27 +35,9 @@ [(query? s) (prove (current-theory) (query-question s))])) -(define (eval-program/fresh p) - (let loop ([thy (make-immutable-theory)] - [p p]) - (if (empty? p) - thy - (let ([s (first p)]) - (loop - (cond - [(assertion? s) - (assume-if-safe assume thy s)] - [(retraction? s) - (retract thy (retraction-clause s))] - [(query? s) - (print-questions (prove thy (query-question s))) - thy]) - (rest p)))))) - (provide/contract - [current-theory (parameter/c mutable-theory/c)] + [current-theory (parameter/c theory/c)] [print-questions ((listof question/c) . -> . void)] [eval-program (program/c . -> . void)] [eval-top-level-statement (statement/c . -> . void)] - [eval-statement (statement/c . -> . (or/c void (listof question/c)))] - [eval-program/fresh (program/c . -> . immutable-theory/c)]) \ No newline at end of file + [eval-statement (statement/c . -> . (or/c void (listof question/c)))]) \ No newline at end of file diff --git a/collects/datalog/main.rkt b/collects/datalog/main.rkt index c693521..4aad39a 100644 --- a/collects/datalog/main.rkt +++ b/collects/datalog/main.rkt @@ -2,5 +2,5 @@ (require "runtime.rkt" "stx.rkt") (provide make-theory - mutable-theory/c + theory/c (all-from-out "stx.rkt")) \ No newline at end of file diff --git a/collects/datalog/runtime.rkt b/collects/datalog/runtime.rkt index f0715fd..481d1c8 100644 --- a/collects/datalog/runtime.rkt +++ b/collects/datalog/runtime.rkt @@ -20,17 +20,13 @@ (clause-body c))) head-vars)) -(define theory/c (coerce-contract 'exec hash?)) -(define immutable-theory/c (and/c hash? immutable?)) -(define mutable-theory/c (and/c hash? (not/c immutable?))) +(define theory/c (and/c hash? (not/c immutable?))) (define (literal-key l) (format "~a/~a" (literal-predicate l) (length (literal-terms l)))) (define (clause-key c) (literal-key (clause-head c))) -(define (make-immutable-theory) - (make-immutable-hash empty)) -(define (make-mutable-theory) +(define (make-theory) (make-hash)) (define ((mk-assume hash-update) thy c) @@ -142,13 +138,7 @@ (provide/contract [safe-clause? (clause? . -> . boolean?)] [theory/c contract?] - [immutable-theory/c contract?] - [mutable-theory/c contract?] - [rename make-mutable-theory make-theory (-> mutable-theory/c)] - [make-mutable-theory (-> mutable-theory/c)] - [make-immutable-theory (-> immutable-theory/c)] - [assume (immutable-theory/c safe-clause? . -> . immutable-theory/c)] - [retract (immutable-theory/c clause? . -> . immutable-theory/c)] - [assume! (mutable-theory/c safe-clause? . -> . void)] - [retract! (mutable-theory/c clause? . -> . void)] + [make-theory (-> theory/c)] + [assume! (theory/c safe-clause? . -> . void)] + [retract! (theory/c clause? . -> . void)] [prove (theory/c question/c . -> . (listof question/c))]) \ No newline at end of file diff --git a/collects/datalog/scribblings/racket.scrbl b/collects/datalog/scribblings/racket.scrbl index f4e3ed4..b0d2677 100644 --- a/collects/datalog/scribblings/racket.scrbl +++ b/collects/datalog/scribblings/racket.scrbl @@ -50,17 +50,17 @@ The Datalog database can be directly used by Racket programs through this API. (datalog family (? (add1 1 :- X)))] -@defthing[mutable-theory/c contract?]{ A contract for Datalog theories. } +@defthing[theory/c contract?]{ A contract for Datalog theories. } -@defproc[(make-theory) mutable-theory/c]{ Creates a theory for use with @racket[datalog]. } +@defproc[(make-theory) theory/c]{ Creates a theory for use with @racket[datalog]. } @defform[(datalog thy-expr stmt ...) - #:contracts ([thy-expr mutable-theory/c])]{ Executes the statements on the theory given by @racket[thy-expr]. Returns the answers to the final query as a list of S-expressions or returns @racket[empty]. } + #:contracts ([thy-expr theory/c])]{ Executes the statements on the theory given by @racket[thy-expr]. Returns the answers to the final query as a list of substitution dictionaries or returns @racket[empty]. } @defform[(datalog! thy-expr stmt ...) - #:contracts ([thy-expr mutable-theory/c])]{ Executes the statements on the theory given by @racket[thy-expr]. Prints the answers to every query in the list of statements. Returns @racket[(void)]. } + #:contracts ([thy-expr theory/c])]{ Executes the statements on the theory given by @racket[thy-expr]. Prints the answers to every query in the list of statements. Returns @racket[(void)]. } Statements are either assertions, retractions, or queries. diff --git a/collects/datalog/sexp/lang.rkt b/collects/datalog/sexp/lang.rkt index 32a692b..c62dc79 100644 --- a/collects/datalog/sexp/lang.rkt +++ b/collects/datalog/sexp/lang.rkt @@ -33,7 +33,7 @@ (define theory (make-theory)) (datalog! theory stmt ...) (provide/contract - [theory mutable-theory/c]))))])) + [theory theory/c]))))])) (define-syntax (top-interaction stx) (syntax-case stx () diff --git a/collects/datalog/stx.rkt b/collects/datalog/stx.rkt index fdff139..ddc0d35 100644 --- a/collects/datalog/stx.rkt +++ b/collects/datalog/stx.rkt @@ -12,12 +12,9 @@ (define-syntax (? stx) (raise-syntax-error '? "only allowed inside datalog" stx)) -(define ->answer - (match-lambda - [(? void?) - empty] - [(? list? ls) - (map literal->sexp ls)])) +(define (->substitutions sel ls) + (if (void? ls) empty + (map sel ls))) (define literal->sexp (match-lambda @@ -38,7 +35,9 @@ [(_ thy-expr stmt ...) (syntax/loc stx (parameterize ([current-theory thy-expr]) - (->answer (eval-statement (datalog-stmt stmt))) + (->substitutions + (datalog-stmt-var-selector stmt) + (eval-statement (datalog-stmt stmt))) ...))])) (define-syntax (datalog! stx) @@ -63,6 +62,17 @@ (quasisyntax/loc #'tstx (query #'#,#'tstx (datalog-literal l)))])) +(define-syntax (datalog-stmt-var-selector stx) + (syntax-parse + stx + #:literals (! ~ ?) + [(_ (~and tstx (! c))) + (quasisyntax/loc #'tstx (λ (l) (hasheq)))] + [(_ (~and tstx (~ c))) + (quasisyntax/loc #'tstx (λ (l) (hasheq)))] + [(_ (~and tstx (? l))) + (quasisyntax/loc #'tstx (datalog-literal-var-selector l))])) + (define-syntax (datalog-clause stx) (syntax-parse stx @@ -93,6 +103,34 @@ (list (datalog-term e) ...)))])) +(define-syntax (datalog-literal-var-selector stx) + (syntax-parse + stx + #:literals (:-) + [(_ sym:id) + (quasisyntax/loc #'sym (λ (l) (hasheq)))] + [(_ (~and tstx (sym:id arg ... :- ans ...))) + (quasisyntax/loc #'tstx + (match-lambda + [(external _srcloc _predsym _pred args anss) + (terms->hasheq (list (datalog-term arg) ... + (datalog-term ans) ...) + (append args anss))]))] + [(_ (~and tstx (sym:id e ...))) + (quasisyntax/loc #'tstx + (match-lambda + [(literal _srcloc _predsym ts) + (terms->hasheq (list (datalog-term e) ...) + ts)]))])) + +(define (terms->hasheq src-ts res-ts) + (for/fold ([h (hasheq)]) + ([src (in-list src-ts)] + [res (in-list res-ts)]) + (if (variable? src) + (hash-set h (variable-sym src) (constant-value res)) + h))) + (define-syntax (datalog-term stx) (syntax-parse stx diff --git a/collects/tests/datalog/racket.rkt b/collects/tests/datalog/racket.rkt index a253658..f0b78e5 100644 --- a/collects/tests/datalog/racket.rkt +++ b/collects/tests/datalog/racket.rkt @@ -14,19 +14,19 @@ (datalog parent (? (parent X joseph2))) => - (list '(parent joseph3 joseph2)) + (list (hasheq 'X 'joseph3)) (datalog parent (? (parent joseph2 X))) => - (list '(parent joseph2 joseph1) - '(parent joseph2 lucy)) + (list (hasheq 'X 'joseph1) + (hasheq 'X 'lucy)) (datalog parent (? (parent joseph2 X)) (? (parent X joseph2))) => - (list '(parent joseph3 joseph2)) + (list (hasheq 'X 'joseph3)) (datalog parent (! (:- (ancestor A B) @@ -41,44 +41,44 @@ (datalog parent (? (ancestor A B))) => - (list '(ancestor joseph3 joseph2) - '(ancestor joseph2 lucy) - '(ancestor joseph2 joseph1) - '(ancestor joseph3 lucy) - '(ancestor joseph3 joseph1)) + (list (hasheq 'A 'joseph3 'B 'joseph2) + (hasheq 'A 'joseph2 'B 'lucy) + (hasheq 'A 'joseph2 'B 'joseph1) + (hasheq 'A 'joseph3 'B 'lucy) + (hasheq 'A 'joseph3 'B 'joseph1)) (let ([x 'joseph2]) (datalog parent (? (parent x X)))) => - (list '(parent joseph2 joseph1) - '(parent joseph2 lucy)) + (list (hasheq 'X 'joseph1) + (hasheq 'X 'lucy)) (datalog parent (? (add1 1 :- X))) => - (list '(add1 1 :- 2)) + (list (hasheq 'X 2)) (local [(local-require tests/datalog/examples/ancestor)] (datalog theory (? (ancestor A B)))) => - '((ancestor ebbon bob) - (ancestor bob john) - (ancestor john douglas) - (ancestor bob douglas) - (ancestor ebbon john) - (ancestor ebbon douglas)) + (list (hasheq 'A 'ebbon 'B 'bob) + (hasheq 'A 'bob 'B 'john) + (hasheq 'A 'john 'B 'douglas) + (hasheq 'A 'bob 'B 'douglas) + (hasheq 'A 'ebbon 'B 'john) + (hasheq 'A 'ebbon 'B 'douglas)) (local [(local-require tests/datalog/paren-examples/ancestor)] (datalog theory (? (ancestor A B)))) => - '((ancestor ebbon bob) - (ancestor bob john) - (ancestor john douglas) - (ancestor bob douglas) - (ancestor ebbon john) - (ancestor ebbon douglas)) + (list (hasheq 'A 'ebbon 'B 'bob) + (hasheq 'A 'bob 'B 'john) + (hasheq 'A 'john 'B 'douglas) + (hasheq 'A 'bob 'B 'douglas) + (hasheq 'A 'ebbon 'B 'john) + (hasheq 'A 'ebbon 'B 'douglas)) ) \ No newline at end of file diff --git a/collects/tests/datalog/runtime.rkt b/collects/tests/datalog/runtime.rkt index 202f8ff..d68fcdc 100644 --- a/collects/tests/datalog/runtime.rkt +++ b/collects/tests/datalog/runtime.rkt @@ -20,31 +20,22 @@ (test-false "not safe" (safe-clause? (parse-clause (open-input-string "ancestor(A, B) :- parent(jay, B)")))) (test-not-false "safe" (safe-clause? (parse-clause (open-input-string "ancestor(A, B) :- parent(A, C), ancestor(C, B)"))))) - (test-suite - "imm simple" - (test-equal? "empty" (prove (make-immutable-theory) pl) empty) - (test-literal "ass->prov" - (first (prove (assume (make-immutable-theory) pc) pl)) - pl) - (test-equal? "ass->ret->prov" (prove (retract (assume (make-immutable-theory) pc) pc) pl) empty) - (test-equal? "ret->prov" (prove (retract (make-immutable-theory) pc) pl) empty)) - (test-suite "mut simple" - (test-equal? "empty" (prove (make-mutable-theory) pl) empty) + (test-equal? "empty" (prove (make-theory) pl) empty) (test-literal "ass->prov" - (let ([thy (make-mutable-theory)]) + (let ([thy (make-theory)]) (assume! thy pc) (first (prove thy pl))) pl) (test-equal? "ass->ret->prov" - (let ([thy (make-mutable-theory)]) + (let ([thy (make-theory)]) (assume! thy pc) (retract! thy pc) (prove thy pl)) empty) (test-equal? "ret->prov" - (let ([thy (make-mutable-theory)]) + (let ([thy (make-theory)]) (retract! thy pc) (prove thy pl)) empty))