summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--chickadee/graphics/seagull.scm360
1 files changed, 260 insertions, 100 deletions
diff --git a/chickadee/graphics/seagull.scm b/chickadee/graphics/seagull.scm
index 05003d9..4cb1a21 100644
--- a/chickadee/graphics/seagull.scm
+++ b/chickadee/graphics/seagull.scm
@@ -981,6 +981,10 @@
`(or ,@(map (lambda (pred)
(apply-substitution-to-predicate pred from to))
preds)))
+ (('list preds ...)
+ `(list ,@(map (lambda (pred)
+ (apply-substitution-to-predicate pred from to))
+ preds)))
(('when test consequent)
`(when ,(apply-substitution-to-predicate test from to)
,(apply-substitution-to-predicate consequent from to)))
@@ -1234,6 +1238,249 @@
(instantiate type)
type)))
+(define (predicate:and . preds)
+ ;; Combine inner 'and' predicates and remove #t predicates.
+ (define preds*
+ (let loop ((preds preds))
+ (match preds
+ (() '())
+ ((('and sub-preds ...) . rest)
+ (append sub-preds (loop rest)))
+ ((#t . rest)
+ (loop rest))
+ ((pred . rest)
+ (cons pred (loop rest))))))
+ (match preds*
+ (() #t)
+ ((pred) pred)
+ (_ `(and ,@preds*))))
+
+(define (predicate:or . preds)
+ (match preds
+ (() #f)
+ ((pred) pred)
+ ((pred ('or sub-preds ...))
+ `(or ,pred ,@sub-preds))
+ (_ `(or ,@preds))))
+
+(define (predicate:list . preds)
+ (define preds*
+ (let loop ((preds preds))
+ (match preds
+ (() '())
+ ((('list sub-preds ...) . rest)
+ (append sub-preds (loop rest)))
+ ((pred . rest)
+ (cons pred (loop rest))))))
+ `(list ,@preds*))
+
+(define (predicate:substitute from to)
+ `(substitute ,from ,to))
+
+(define (predicate:substitutes subs)
+ (apply predicate:and
+ (map (match-lambda
+ ((from . to)
+ (predicate:substitute from to)))
+ subs)))
+
+(define (compose-predicates a b)
+ (cond
+ ((and (eq? a #t) (eq? b #t))
+ #t)
+ ((eq? a #t)
+ b)
+ ((eq? b #t)
+ a)
+ (else
+ (predicate:list a b))))
+
+(define (compose-predicates* preds)
+ (reduce (lambda (pred memo)
+ (compose-predicates pred memo))
+ #t
+ preds))
+
+(define (compose-predicates-for-types types)
+ (compose-predicates* (map predicate-for-type types)))
+
+;; Produces a simplified predicate and a new set of substitutions for
+;; predicates that have been satisfied and simplified to #t. It's a
+;; bit of a weird process since we're dealing with partial evaluation,
+;; simplification, and constraint generation at the same time, so
+;; there are lots of comments explaining what the heck is going on.
+(define (eval-predicate pred)
+ (match pred
+ ;; #t is the simplest predicate. It's always successful and
+ ;; results in no substitutions.
+ (#t (values #t '()))
+ (#f (values #f '()))
+ ;; '=' asserts that 'a' must equal 'b'. If either is a type
+ ;; variable, then we don't have enough information to determine
+ ;; success or failure.
+ ((or ('= (? type-variable?) _)
+ ('= _ (? type-variable?)))
+ (values pred '()))
+ ;; Neither argument is a type variable, so we can get an answer.
+ (('= a b)
+ (values (equal? a b) '()))
+ ;; An 'or' succeeds if any of the predicates within succeed.
+ (('or preds ...)
+ (match preds
+ ;; No clause succeeded or the 'or' had no clauses to begin
+ ;; with. Either way, the 'or' fails.
+ (() (values #f '()))
+ ((pred* . rest)
+ (define-values (new-pred subs)
+ (eval-predicate pred*))
+ (match new-pred
+ ;; This clause succeeded, so the entire 'or' can be
+ ;; reduced to #t.
+ (#t (values #t subs))
+ ;; This clause failed, so simplify the 'or' to just the
+ ;; rest of the clauses.
+ (#f (eval-predicate (apply predicate:or rest)))
+ ;; There isn't enough information to determine if this
+ ;; clause will succeed or fail. So, we evaluate the rest
+ ;; of the 'or' clauses and compose the result with this
+ ;; undetermined clause.
+ (_
+ (define-values (rest-pred subs*)
+ (eval-predicate (apply predicate:or rest)))
+ (match rest-pred
+ ;; All of the other 'or' clauses have failed, so the
+ ;; 'or' can be removed entirely and reduced to the
+ ;; undetermined predicate.
+ (#f (values new-pred '()))
+ ;; The rest of the 'or' succeeded, so we can form a
+ ;; series of 'substitute' forms so that if this
+ ;; undetermined clause fails the substitutions from the
+ ;; rest of 'or' will still be respected.
+ (#t
+ (values (predicate:or new-pred (predicate:substitutes subs*))
+ '()))
+ ;; The rest of the 'or' clauses have an undetermined
+ ;; answer, so the result is an 'or'.
+ (_
+ (values (predicate:or new-pred rest-pred) '()))))))))
+ ;; An 'and' succeeds if *all* of the predicates within succeed.
+ (('and preds ...)
+ (match preds
+ ;; All of the 'and' clauses succeed, so the 'and' succeeds.
+ (()
+ (values #t '()))
+ ((pred* . rest)
+ (define-values (new-pred subs)
+ (eval-predicate pred*))
+ (match new-pred
+ ;; The first 'and' clause is successful, so test the rest of
+ ;; the clauses and compose the substitutes.
+ (#t
+ (let ()
+ (define-values (rest-pred subs*)
+ (eval-predicate (apply predicate:and rest)))
+ (match rest-pred
+ ;; The rest of the 'and' clauses are successful, so the
+ ;; entire 'and' is successful and we can return the
+ ;; substitutions.
+ (#t
+ (values #t (compose-substitutions subs subs*)))
+ ;; At least one of the remaining clauses has failed, so
+ ;; the 'and' fails.
+ (#f
+ (values #f '()))
+ ;; The rest of the 'and' is undetermined, so form a new
+ ;; and that will perform the substitutions generated by
+ ;; this clause if the rest of the 'and' eventually
+ ;; succeeds.
+ (_
+ (values (predicate:and rest-pred (predicate:substitutes subs))
+ '())
+ ;; (values (predicate:and rest-pred)
+ ;; subs*)
+ ))))
+ ;; The clause failed, so the 'and' fails.
+ (#f (values #f '()))
+ ;; The clause is undetermined, so evaluate the rest of the
+ ;; clauses and attempt to simply the resulting 'and'
+ ;; expression.
+ (_
+ (define-values (rest-pred subs*)
+ (eval-predicate (apply predicate:and rest)))
+ (match rest-pred
+ ;; One of the remaining clauses fails, so even if the
+ ;; undetermined clause were to succeed later, the 'and'
+ ;; is going to fail so just fail now.
+ (#f (values #f '()))
+ ;; The remaining clauses pass, so we replace them with
+ ;; substitutions that will occur should this
+ ;; undertermined clause eventually succeed.
+ (#t
+ (values (predicate:and new-pred (predicate:substitutes subs*))
+ '()))
+ ;; The remaining clauses have an undetermined result, so
+ ;; construct a new 'and'.
+ (_
+ (values (predicate:and new-pred rest-pred) '()))))))))
+ ;; A 'list' predicate is like an 'or' except if any clause
+ ;; succeeds the substitutions are propagated to the caller along
+ ;; with a new list withou the successful clause. This is how
+ ;; multiple independent predicates are composed.
+ (('list preds ...)
+ (match preds
+ ;; No predicates, no failure.
+ (() (values #t '()))
+ ((pred* . rest)
+ (define-values (new-pred subs)
+ (eval-predicate pred*))
+ (match new-pred
+ ;; This clause succeeded, so remove it from the result, eval
+ ;; the rest of the clauses, and pass along the substitutions.
+ (#t
+ (let ()
+ (define-values (rest-pred subs*)
+ (eval-predicate (apply predicate:list rest)))
+ (values rest-pred (compose-substitutions subs subs*))))
+ ;; This clause failed, so the whole predicate fails.
+ (#f (values #f '()))
+ ;; There isn't enough information to determine if this
+ ;; clause will succeed or fail. So, we evaluate the rest of
+ ;; the clauses and compose the result with this undetermined
+ ;; clause.
+ (_
+ (define-values (rest-pred subs*)
+ (eval-predicate (apply predicate:list rest)))
+ (values (predicate:list pred* rest-pred) subs*))))))
+ (('when test consequent)
+ (define-values (new-test subs)
+ (eval-predicate test))
+ (match new-test
+ (#t
+ (let ()
+ (define-values (new-consequent subs*)
+ (eval-predicate consequent))
+ (values new-consequent (compose-substitutions subs subs*))))
+ (#f (values #f '()))
+ (_ (values `(when ,new-test ,consequent) '()))))
+ ;; Substitution always succeeds and returns a substitution to be
+ ;; carried forward in the inference process.
+ (('substitute a b)
+ (values #t (list (cons a b))))))
+
+(define (eval-predicate* pred subs)
+ (define-values (new-pred pred-subs)
+ (eval-predicate
+ (apply-substitutions-to-predicate pred subs)))
+ ;; TODO: Get information about *why* the predicate failed.
+ (unless new-pred
+ (error "predicate failure"))
+ ;; Recursively evaluate the predicate, applying the substitutions
+ ;; generated by the last evaluation, until it cannot be simplified
+ ;; any further.
+ (if (null? pred-subs)
+ (values new-pred subs)
+ (eval-predicate* new-pred (compose-substitutions subs pred-subs))))
+
(define* (free-variables-in-type type)
(cond
((primitive-type? type) '())
@@ -1290,6 +1537,10 @@
(append-map (lambda (pred)
(free-variables-in-predicate pred))
preds))
+ (('list preds ...)
+ (append-map (lambda (pred)
+ (free-variables-in-predicate pred))
+ preds))
(('when test consequent)
(append (free-variables-in-predicate test)
(free-variables-in-predicate consequent)))
@@ -1332,98 +1583,6 @@
(values (map first types+preds)
(reduce compose-predicates #t (map second types+preds))))
-;; (define (strip-qualifier type)
-;; (if (qualified-type? type)
-;; (qualified-type-ref type)
-;; type))
-
-;; (define (strip-qualifiers types)
-;; (map strip-qualifier types))
-
-;; (define (predicate-for-type type)
-;; (if (qualified-type? type)
-;; (qualified-type-predicate type)
-;; #t))
-
-(define (compose-predicates a b)
- (cond
- ((and (eq? a #t) (eq? b #t))
- #t)
- ((eq? a #t)
- b)
- ((eq? b #t)
- a)
- (else
- `(and ,a ,b))))
-
-(define (compose-predicates* preds)
- (reduce (lambda (pred memo)
- (compose-predicates pred memo))
- #t
- preds))
-
-(define (compose-predicates-for-types types)
- (compose-predicates* (map predicate-for-type types)))
-
-;; Produces a simplified predicate and a new set of substitutions for
-;; predicates that have been satisfied and simplified to #t.
-(define (eval-predicate pred)
- (match pred
- (#t (values #t '()))
- ((or ('= (? type-variable?) _)
- ('= _ (? type-variable?)))
- (values pred '()))
- (('= a b)
- (values (equal? a b) '()))
- (('or preds ...)
- (let loop ((preds preds))
- (match preds
- (() (values #f '()))
- ((pred* . rest)
- (define-values (new-pred subs)
- (eval-predicate pred*))
- (match new-pred
- (#t (values #t subs))
- (#f (eval-predicate `(or ,@rest)))
- (_ (values `(or ,new-pred ,@rest) '())))))))
- (('and preds ...)
- (let loop ((preds preds))
- (match preds
- (() (values #t '()))
- ((pred* . rest)
- (define-values (new-pred subs)
- (eval-predicate pred*))
- (match new-pred
- (#t
- (let ()
- (define-values (new-pred* subs*)
- (eval-predicate `(and ,@rest)))
- (values new-pred* (compose-substitutions subs subs*))))
- (#f (values #f '()))
- (_ (values `(and ,new-pred ,@rest) '())))))))
- (('when test consequent)
- (define-values (new-test subs)
- (eval-predicate test))
- (match new-test
- (#t
- (let ()
- (define-values (new-consequent subs*)
- (eval-predicate consequent))
- (values new-consequent (compose-substitutions subs subs*))))
- (#f (values #f '()))
- (_ (values `(when ,new-test ,consequent) '()))))
- (('substitute a b)
- (values #t (list (cons a b))))))
-
-(define (eval-predicate* pred subs)
- (define-values (new-pred pred-subs)
- (eval-predicate
- (apply-substitutions-to-predicate pred subs)))
- ;; TODO: Get information about *why* the predicate failed.
- (unless new-pred
- (error "predicate failure"))
- (values new-pred (compose-substitutions subs pred-subs)))
-
(define (unify:primitives a b)
(if (equal? a b)
'()
@@ -1774,14 +1933,15 @@
(c (fresh-type-variable)))
(for-all-type
(list a b c)
- (function-type (list a b)
- (list c))
- `(or (when (and (= ,a ,int-type)
- (= ,b ,int-type))
- (substitute ,c ,a))
- (when (and (= ,a ,float-type)
- (= ,b ,float-type))
- (substitute ,c ,a))))))
+ (function-type (list a b) (list c))
+ `(or (and (= ,a ,int-type)
+ (= ,b ,int-type)
+ (substitute ,c ,a))
+
+ (and (= ,a ,float-type)
+ (= ,b ,float-type)
+ (substitute ,c ,a))
+ ))))
(empty-env)))
;; TODO: Add some kind of context object that is threaded through the