You cannot select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
beautiful-racket/beautiful-racket-ragg/br/ragg/codegen/satisfaction.rkt

208 lines
4.6 KiB
Racket

9 years ago
#lang racket/base
(provide make-and make-or node? node-val node-yes? visit! add-child!)
(require racket/match)
;; I can't get no... satisfaction.
;;
;; A small module to make sure a small constraint system can be satisfied.
;;
;; Small variation on topological sort where we need both AND and OR nodes.
(struct node (type val yes? parents count-to-satisfy) #:mutable)
;; or nodes are satisfied if any of the children is satisfied.
;; and nodes are satisfied if all of the children are satisfied.
;; visit!: node -> void
;; Visit a node, and marking it if it's all satisfied. Propagate
;; satisfaction to parents as appropriate.
(define visit!
(let ()
(define (dec! n)
(set-node-count-to-satisfy! n (max 0 (sub1 (node-count-to-satisfy n))))
(when (and (not (node-yes? n))
(= (node-count-to-satisfy n) 0))
(sat! n)))
(define (sat! n)
(set-node-yes?! n #t)
(for ([p (in-list (node-parents n))])
(dec! p)))
(lambda (n)
(unless (node-yes? n)
(when (= (node-count-to-satisfy n) 0)
(sat! n))))))
;; make-or: X -> node
;; Create an or node
(define (make-or [val #f])
(node 'or val #f '() 1))
;; make-and: X -> node
;; Create an and node
(define (make-and [val #f])
(node 'and val #f '() 0))
;; add-child!: node node -> void
;; Attach a child c to the parent node p.
(define (add-child! p c)
(set-node-parents! c (cons p (node-parents c)))
(match p
[(node 'or _ _ _ count-to-satisfy)
(void)]
[(node 'and _ _ _ count-to-satisfy)
(set-node-count-to-satisfy! p (add1 count-to-satisfy))]))
(module* test racket
(require (submod "..")
racket/block
rackunit)
;; a ::= a
(block
;; Self-looping "a" and-node should not say yes after visiting.
(define a (make-and 'a))
(add-child! a a)
(visit! a)
(check-false (node-yes? a)))
;; a ::= a
(block
;; Self-looping "a" or-node should not say yes after visiting.
(define a (make-or 'a))
(add-child! a a)
(visit! a)
(check-false (node-yes? a)))
;; This case should never happen in my situation, but we should check.
(block
;; Empty "a" or-node should not say yes after visiting.
(define a (make-or 'a))
(visit! a)
(check-false (node-yes? a)))
;; a : TOKEN
(block
;; Empty "a" and-node SHOULD say yes after visiting.
(define a (make-and 'a))
(visit! a)
(check-true (node-yes? a)))
;; a : a | b
;; b : TOKEN
(block
(define a (make-or 'a))
(add-child! a a)
(define b (make-and 'b))
(add-child! a b)
(visit! b)
(check-true (node-yes? a))
(check-true (node-yes? b)))
;; a : a b
;; b : TOKEN
(block
(define a (make-and 'a))
(define b (make-and 'b))
(define TOKEN (make-and 'TOKEN))
(add-child! a a)
(add-child! a b)
(add-child! b TOKEN)
(visit! TOKEN)
(check-false (node-yes? a))
(check-true (node-yes? b))
(check-true (node-yes? TOKEN)))
;; a : b
;; b : a
(block
(define a (make-and 'a))
(define b (make-and 'b))
(add-child! a b)
(add-child! b a)
(check-false (node-yes? a))
(check-false (node-yes? b)))
;; a : "a" b
;; b : a | b
(block
(define a (make-and 'a))
(define b (make-or 'b))
(define lit (make-and "a"))
(add-child! a lit)
(add-child! a b)
(add-child! b a)
(add-child! b b)
(visit! lit)
(check-false (node-yes? a))
(check-false (node-yes? b))
(check-true (node-yes? lit)))
;; x : x y
;; y : LIT
(block
(define x (make-and "x"))
(define y (make-and "y"))
(define lit (make-and "LIT"))
(add-child! x x)
(add-child! x y)
(add-child! y lit)
(visit! lit)
(check-false (node-yes? x))
(check-true (node-yes? y))
(check-true (node-yes? lit)))
;; expr: LPAREN expr RPAREN | ATOM
(block
(define LPAREN (make-and))
(define RPAREN (make-and))
(define expr (make-or))
(define expr-1 (make-and))
(define expr-2 (make-and))
(define ATOM (make-and))
(add-child! expr expr-1)
(add-child! expr expr-2)
(add-child! expr-1 LPAREN)
(add-child! expr-1 expr)
(add-child! expr-1 RPAREN)
(add-child! expr-2 ATOM)
(visit! LPAREN)
(visit! RPAREN)
(visit! ATOM)
(check-true (node-yes? expr)))
;; expr: LPAREN expr RPAREN
(block
(define LPAREN (make-and))
(define RPAREN (make-and))
(define expr (make-or))
(define expr-1 (make-and))
(define expr-2 (make-and))
(define ATOM (make-and))
(add-child! expr expr-1)
(add-child! expr expr-2)
(add-child! expr-1 LPAREN)
(add-child! expr-1 expr)
(add-child! expr-1 RPAREN)
(visit! LPAREN)
(visit! RPAREN)
(check-false (node-yes? expr)))
)