rewrote unify* to use #2dmatch
This commit is contained in:
Robby Findler
parent
5cc2ec0cca
commit
506566ac6a
|
|
@ -1,4 +1,4 @@
|
||||||
#lang racket/base
|
#lang unstable/2d racket/base
|
||||||
|
|
||||||
(require racket/list
|
(require racket/list
|
||||||
racket/contract
|
racket/contract
|
||||||
|
|
@ -10,7 +10,8 @@
|
||||||
"extract-conditions.rkt"
|
"extract-conditions.rkt"
|
||||||
"enum.rkt"
|
"enum.rkt"
|
||||||
(for-syntax "rewrite-side-conditions.rkt"
|
(for-syntax "rewrite-side-conditions.rkt"
|
||||||
racket/base))
|
racket/base)
|
||||||
|
unstable/2d/match)
|
||||||
|
|
||||||
(provide unify
|
(provide unify
|
||||||
unify*
|
unify*
|
||||||
|
|
@ -386,31 +387,64 @@
|
||||||
(define (unify* t0 u0 e L)
|
(define (unify* t0 u0 e L)
|
||||||
(define t (resolve t0 e))
|
(define t (resolve t0 e))
|
||||||
(define u (resolve u0 e))
|
(define u (resolve u0 e))
|
||||||
(match* (t u)
|
#2dmatch
|
||||||
;; mismatch patterns
|
╔═════════════════╦═════════════════╦═════════════╦═══════════════╦═══════════╦══════╦════════════╦══════════════╦═══════════╦═══════════╦═════════╦══════════╦══════════════╦═════════════╗
|
||||||
[(`(mismatch-name ,name ,t-pat) u)
|
║ u ║ `(mismatch-name ║ `(name ║ `(cstr ║`(nt ,n-u) ║`any ║ (? num-ty?)║`(list ║ (? vnom?) ║ `variable ║ `string ║ `boolean ║ (? base-ty?) ║(? not-pair?)║
|
||||||
(hash-set! (dqs-found) name
|
║ ║ ,u-name ║ ,name-u ║ (,nts1 ...) ║ ║ ║ ║ ,us ...) ║ ║ ║ ║ ║ ║ ║
|
||||||
(cons u (hash-ref (dqs-found) name (λ () '()))))
|
║ t ║ ,u-pat) ║ ,(bound)) ║ ,p1) ║ ║ ║ ║ ║ ║ ║ ║ ║ ║ ║
|
||||||
(unify* t-pat u e L)]
|
╠═════════════════╬═════════════════╩═════════════╩═══════════════╩═══════════╩══════╩════════════╩══════════════╩═══════════╩═══════════╩═════════╩══════════╩══════════════╩═════════════╣
|
||||||
[(t `(mismatch-name ,name ,u-pat))
|
║`(mismatch-name ║ (hash-set! (dqs-found) t-name (cons u (hash-ref (dqs-found) t-name (λ () '())))) ║
|
||||||
(hash-set! (dqs-found) name
|
║ ,t-name ║ (unify* t-pat u e L) ║
|
||||||
(cons t (hash-ref (dqs-found) name (λ () '()))))
|
║ ,t-pat) ║ ║
|
||||||
(unify* t u-pat e L)]
|
╠═════════════════╬═════════════════╦══════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════╣
|
||||||
;; named pats always pre-bound here
|
║`(name ,name-t ║ ║ (instantiate* name-t u e L) ║
|
||||||
[(`(name ,name ,(bound)) _)
|
║ ,(bound)) ║ ║ ║
|
||||||
(instantiate* name u e L)]
|
╠═════════════════╣ ╚═════════════╦═══════════════╦════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════╣
|
||||||
[(_ `(name ,name ,(bound)))
|
║`(cstr ║ ║(u*-2cstrs ║ (u*-1cstr nts2 p2 u e L) ║
|
||||||
(unify* u t e L)]
|
║ (,nts2 ...) ║ ║ nts1 p1 ║ ║
|
||||||
;; cstrs
|
║ ,p2) ║ ║ nts2 p2 e L) ║ ║
|
||||||
[(`(cstr (,nts1 ...) ,p1) `(cstr (,nts2 ...) ,p2))
|
╠═════════════════╣ ╚═══════════════╬═══════════╦════════════════════════════════════════════════════════════════════════════════════════════════════════════╣
|
||||||
|
║ `(nt ,n-t) ║ ║(u*-2nts ║ (u*-1nt n-t u e L) ║
|
||||||
|
║ ║ ║ n-t n-u ║ ║
|
||||||
|
║ ║ ║ e L) ║ ║
|
||||||
|
╠═════════════════╣ ╚═══════════╬════════════════════════════════════════════════════════════════════════════════════════════════════════════╣
|
||||||
|
║ `any ║ ║ u ║
|
||||||
|
║ ║ ║ ║
|
||||||
|
╠═════════════════╣ ╚══════╦════════════╦══════════════════════════════════════════════════════════════════════════╦═════════════╣
|
||||||
|
║ (? num-ty?) ║ ║(u*-2nums ║ ║ ║
|
||||||
|
║ ║ ║ t u) ║ ║ ║
|
||||||
|
╠═════════════════╣ ╚════════════╬══════════════╗ ║ ║
|
||||||
|
║ `(list ,ts ...) ║ ║(u*-2lsts ║ (unif-fail) ║ ║
|
||||||
|
║ ║ ║ ts us e L) ║ ║(u*-matches? ║
|
||||||
|
╠═════════════════╣ ╚══════════════╬═══════════╦═══════════╗ ║ t u ║
|
||||||
|
║ (? vnom?) ║ ║ t ║ t ║ ║ e L) ║
|
||||||
|
╠═════════════════╣ ╚═══════════╬═══════════╣ ║ ║
|
||||||
|
║ `variable ║ ║ t ║ ║ ║
|
||||||
|
╠═════════════════╣ ╚═══════════╬═════════╗ ║ ║
|
||||||
|
║ `string ║ (unify* u t e L) ║ t ║ ║ ║
|
||||||
|
╠═════════════════╣ ╚═════════╬══════════╗ ║ ║
|
||||||
|
║ `boolean ║ ║ t ║ ║ ║
|
||||||
|
╠═════════════════╣ ╚══════════╬══════════════╣ ║
|
||||||
|
║ (? base-ty?) ║ ║ t ║ ║
|
||||||
|
╠═════════════════╣ ╚══════════════╬═════════════╣
|
||||||
|
║ (? not-pair?) ║ ║(and/fail ║
|
||||||
|
║ ║ ║ (equal? t u)║
|
||||||
|
║ ║ ║ t) ║
|
||||||
|
╚═════════════════╩══════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════╩═════════════╝)
|
||||||
|
|
||||||
|
(define (vnom? x) (equal? x 'variable-not-otherwise-mentioned))
|
||||||
|
(define (not-pair? x) (not (pair? x)))
|
||||||
|
|
||||||
|
(define (u*-2cstrs nts1 p1 nts2 p2 e L)
|
||||||
(let ([res (unify* p1 p2 e L)]
|
(let ([res (unify* p1 p2 e L)]
|
||||||
[new-nts (merge-ids/sorted nts1 nts2 L)])
|
[new-nts (merge-ids/sorted nts1 nts2 L)])
|
||||||
(and/fail (not-failed? res)
|
(and/fail (not-failed? res)
|
||||||
new-nts
|
new-nts
|
||||||
(when (lvar? res)
|
(when (lvar? res)
|
||||||
(error 'unify* "unify* returned lvar as result: ~s\n~s\n~s\n" p1 p2 e))
|
(error 'unify* "unify* returned lvar as result: ~s\n~s\n~s\n" p1 p2 e))
|
||||||
`(cstr ,new-nts ,res)))]
|
`(cstr ,new-nts ,res))))
|
||||||
[(`(cstr ,nts ,p) _)
|
|
||||||
|
(define (u*-1cstr nts p u e L)
|
||||||
(let ([res (unify* p u e L)])
|
(let ([res (unify* p u e L)])
|
||||||
(and/fail (not-failed? res)
|
(and/fail (not-failed? res)
|
||||||
(match res
|
(match res
|
||||||
|
|
@ -426,15 +460,17 @@
|
||||||
`(cstr ,new-nts ,new-p))]
|
`(cstr ,new-nts ,new-p))]
|
||||||
[_
|
[_
|
||||||
(and/fail (for/and ([n nts]) (check-nt n L res))
|
(and/fail (for/and ([n nts]) (check-nt n L res))
|
||||||
`(cstr ,nts ,res))])))]
|
`(cstr ,nts ,res))]))))
|
||||||
[(_ `(cstr ,nts ,p))
|
|
||||||
(unify* `(cstr ,nts ,p) t e L)]
|
(define (u*-2nts n-t n-u e L)
|
||||||
;; nts
|
(if (equal? n-t n-u)
|
||||||
[(`(nt ,n) `(nt ,n))
|
(let ([n n-t])
|
||||||
(if (hash-has-key? (compiled-lang-collapsible-nts L) n)
|
(if (hash-has-key? (compiled-lang-collapsible-nts L) n)
|
||||||
(hash-ref (compiled-lang-collapsible-nts L) n)
|
(hash-ref (compiled-lang-collapsible-nts L) n)
|
||||||
`(nt ,n))]
|
`(nt ,n)))
|
||||||
[(`(nt ,p) u)
|
(u*-1nt n-t `(nt ,n-u) e L)))
|
||||||
|
|
||||||
|
(define (u*-1nt p u e L)
|
||||||
(and/fail
|
(and/fail
|
||||||
(check-nt p L u)
|
(check-nt p L u)
|
||||||
(if (hash-has-key? (compiled-lang-collapsible-nts L) p)
|
(if (hash-has-key? (compiled-lang-collapsible-nts L) p)
|
||||||
|
|
@ -443,69 +479,38 @@
|
||||||
(and/fail (not-failed? res)
|
(and/fail (not-failed? res)
|
||||||
(when (lvar? res)
|
(when (lvar? res)
|
||||||
(error 'unify* "unify* returned lvar as result: ~s\n~s\n~s\n" u u e))
|
(error 'unify* "unify* returned lvar as result: ~s\n~s\n~s\n" u u e))
|
||||||
`(cstr (,p) ,res)))))]
|
`(cstr (,p) ,res))))))
|
||||||
[(_ `(nt ,p))
|
|
||||||
(unify* `(nt ,p) t e L)]
|
(define (u*-2lsts ts us e L)
|
||||||
;; other pat stuff
|
|
||||||
[(`(list ,ts ...) `(list ,us ...))
|
|
||||||
(and/fail (= (length ts) (length us))
|
(and/fail (= (length ts) (length us))
|
||||||
(let/ec fail
|
(let/ec fail
|
||||||
`(list ,@(for/list ([t ts] [u us])
|
`(list ,@(for/list ([t ts] [u us])
|
||||||
(let ([res (unify* t u e L)])
|
(let ([res (unify* t u e L)])
|
||||||
(if (not-failed? res)
|
(if (not-failed? res)
|
||||||
res
|
res
|
||||||
(fail (unif-fail))))))))]
|
(fail (unif-fail)))))))))
|
||||||
[((? number-type? t) (? number-type? u))
|
|
||||||
|
(define (u*-2nums t u)
|
||||||
(cond
|
(cond
|
||||||
[(number-superset? t u) u]
|
[(number-superset? t u) u]
|
||||||
[(number-superset? u t) t])]
|
[(number-superset? u t) t]))
|
||||||
[((? number-type? t) _)
|
|
||||||
|
(define (u*-matches? t u e L)
|
||||||
|
(match* (t u)
|
||||||
|
[((? num-ty? t) _)
|
||||||
(and/fail ((number-pred t) u)
|
(and/fail ((number-pred t) u)
|
||||||
u)]
|
u)]
|
||||||
[(_ (? number-type? u))
|
|
||||||
(unify* u t e L)]
|
|
||||||
[(`variable-not-otherwise-mentioned `variable-not-otherwise-mentioned)
|
|
||||||
`variable-not-otherwise-mentioned]
|
|
||||||
[(_ `variable-not-otherwise-mentioned)
|
|
||||||
(unify* u t e L)]
|
|
||||||
[(`variable-not-otherwise-mentioned `variable)
|
|
||||||
`variable-not-otherwise-mentioned]
|
|
||||||
[(`variable-not-otherwise-mentioned (? symbol? s))
|
[(`variable-not-otherwise-mentioned (? symbol? s))
|
||||||
(and/fail (not (memq s (compiled-lang-literals L)))
|
(and/fail (not (memq s (compiled-lang-literals L)))
|
||||||
(not (base-type? s))
|
(not (base-ty? s))
|
||||||
s)]
|
s)]
|
||||||
[(`variable `variable)
|
|
||||||
`variable]
|
|
||||||
[(_ `variable)
|
|
||||||
(unify* u t e L)]
|
|
||||||
[(`variable (? symbol? s))
|
[(`variable (? symbol? s))
|
||||||
(and/fail (not (base-type? s))
|
(and/fail (not (base-ty? s))
|
||||||
s)]
|
s)]
|
||||||
;; string stuff
|
|
||||||
[(`string `string)
|
|
||||||
`string]
|
|
||||||
[(_ `string)
|
|
||||||
(unify* u t e L)]
|
|
||||||
[(`string (? string? s))
|
[(`string (? string? s))
|
||||||
s]
|
s]
|
||||||
|
|
||||||
;; booleans
|
|
||||||
[(`boolean `boolean)
|
|
||||||
`boolean]
|
|
||||||
[(`string `boolean)
|
|
||||||
(unif-fail)]
|
|
||||||
[(_ `boolean)
|
|
||||||
(unify* u t e L)]
|
|
||||||
[(`boolean (? boolean? b))
|
[(`boolean (? boolean? b))
|
||||||
b]
|
b]
|
||||||
|
|
||||||
;; other
|
|
||||||
[((? base-type? t) (? base-type? u))
|
|
||||||
(and/fail (equal? t u)
|
|
||||||
t)]
|
|
||||||
[((? (compose not pair?) t) (? (compose not pair?) u))
|
|
||||||
(and/fail (equal? t u)
|
|
||||||
t)]
|
|
||||||
[(_ _) (unif-fail)]))
|
[(_ _) (unif-fail)]))
|
||||||
|
|
||||||
(define (resolve pat env)
|
(define (resolve pat env)
|
||||||
|
|
@ -649,16 +654,15 @@
|
||||||
[`(,a ,b ,rest ...)
|
[`(,a ,b ,rest ...)
|
||||||
(cons a (de-dupe/sorted (cons b rest)))]))
|
(cons a (de-dupe/sorted (cons b rest)))]))
|
||||||
|
|
||||||
(define (number-type? symbol)
|
(define (num-ty? symbol)
|
||||||
(member symbol
|
(member symbol
|
||||||
'(any number real integer natural)))
|
'(number real integer natural)))
|
||||||
|
|
||||||
(define npreds (hash 'number number?
|
(define npreds (hash 'number number?
|
||||||
'real real?
|
'real real?
|
||||||
'integer integer?
|
'integer integer?
|
||||||
'natural (λ (n) (and (integer? n)
|
'natural (λ (n) (and (integer? n)
|
||||||
(>= n 0)))
|
(>= n 0)))))
|
||||||
'any (λ (n) #t)))
|
|
||||||
(define (number-pred symbol)
|
(define (number-pred symbol)
|
||||||
(hash-ref npreds symbol))
|
(hash-ref npreds symbol))
|
||||||
|
|
||||||
|
|
@ -667,7 +671,7 @@
|
||||||
(>= (length (member super nums))
|
(>= (length (member super nums))
|
||||||
(length (member sub nums))))
|
(length (member sub nums))))
|
||||||
|
|
||||||
(define (base-type? symbol)
|
(define (base-ty? symbol)
|
||||||
(member symbol
|
(member symbol
|
||||||
'(any number string natural integer real boolean
|
'(any number string natural integer real boolean
|
||||||
variable variable-not-otherwise-mentioned)))
|
variable variable-not-otherwise-mentioned)))
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user