114 lines
4.7 KiB
Racket
114 lines
4.7 KiB
Racket
#lang racket/base
|
|
;;; SPDX-License-Identifier: LGPL-3.0-or-later
|
|
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
|
|
|
|
(require "../../skeleton.rkt")
|
|
(require (submod "../../skeleton.rkt" for-test))
|
|
|
|
(module+ test
|
|
(require rackunit)
|
|
|
|
(struct a (x y) #:transparent)
|
|
(struct b (v) #:transparent)
|
|
(struct c (v) #:transparent)
|
|
(struct d (x y z) #:transparent)
|
|
|
|
(define sk
|
|
(make-empty-skeleton/cache
|
|
(make-hash (for/list [(x (list (a (b 'bee) (b 'cat))
|
|
(a (b 'foo) (c 'bar))
|
|
(a (b 'foo) (c 'BAR))
|
|
(a (c 'bar) (b 'foo))
|
|
(a (c 'dog) (c 'fox))
|
|
(d (b 'DBX) (b 'DBY) (b 'DBZ))
|
|
(d (c 'DCX) (c 'DCY) (c 'DCZ))
|
|
(b 'zot)
|
|
123))]
|
|
(cons x #t)))))
|
|
|
|
(define i1
|
|
(skeleton-interest (list struct:a (list struct:b #f) #f)
|
|
'((0 0))
|
|
'(foo)
|
|
'((1))
|
|
(lambda (op . bindings)
|
|
(printf "xAB HANDLER: ~v ~v\n" op bindings))
|
|
(lambda (vars)
|
|
(printf "xAB CLEANUP: ~v\n" vars))))
|
|
|
|
(add-interest! sk i1)
|
|
|
|
(void (extend-skeleton! sk (list struct:a (list struct:b #f) #f)))
|
|
(void (extend-skeleton! sk (list struct:a #f (list struct:c #f))))
|
|
(void (extend-skeleton! sk (list struct:a #f (list struct:c (list struct:b #f)))))
|
|
(void (extend-skeleton! sk (list struct:a #f #f)))
|
|
(void (extend-skeleton! sk (list struct:c #f)))
|
|
(void (extend-skeleton! sk (list struct:b #f)))
|
|
(void (extend-skeleton! sk (list struct:d (list struct:b #f) #f (list struct:b #f))))
|
|
(void (extend-skeleton! sk (list struct:d (list struct:b #f) #f (list struct:c #f))))
|
|
(void (extend-skeleton! sk (list struct:d (list struct:c #f) #f (list struct:b #f))))
|
|
(void (extend-skeleton! sk (list struct:d (list struct:c #f) #f (list struct:c #f))))
|
|
(check-eq? sk (extend-skeleton! sk #f))
|
|
|
|
(add-interest! sk
|
|
(skeleton-interest (list struct:d (list struct:b #f) #f (list struct:c #f))
|
|
'((2 0))
|
|
'(DCZ)
|
|
'(() (0) (0 0) (1))
|
|
(lambda (op . bindings)
|
|
(printf "DBC HANDLER: ~v ~v\n" op bindings))
|
|
(lambda (vars)
|
|
(printf "DBC CLEANUP: ~v\n" vars))))
|
|
|
|
(remove-assertion! sk (a (b 'foo) (c 'bar)))
|
|
(remove-assertion! sk (d (b 'B1) (b 'DBY) (c 'DCZ)))
|
|
(add-assertion! sk (d (b 'B1) (b 'DBY) (c 'DCZ)))
|
|
(add-assertion! sk (d (b 'BX) (b 'DBY) (c 'DCZ)))
|
|
(add-assertion! sk (d (b 'B1) (b 'DBY) (c 'CX)))
|
|
(add-assertion! sk (d (b 'B1) (b 'DBY) (c 'DCZ)))
|
|
(add-assertion! sk (d (b 'BX) (b 'DBY) (c 'DCZ)))
|
|
(add-assertion! sk (d (b 'B1) (b 'DBY) (c 'CX)))
|
|
|
|
(add-interest! sk
|
|
(skeleton-interest (list struct:d #f (list struct:b #f) #f)
|
|
'((1 0))
|
|
'(DBY)
|
|
'((0) (2))
|
|
(lambda (op . bindings)
|
|
(printf "xDB HANDLER: ~v ~v\n" op bindings))
|
|
(lambda (vars)
|
|
(printf "xDB CLEANUP: ~v\n" vars))))
|
|
|
|
(send-assertion! sk (d (b 'BX) (b 'DBY) (c 'DCZ)))
|
|
(send-assertion! sk (d (b 'BX) (b 'DBY) (c 'DCZ)))
|
|
|
|
(remove-assertion! sk (d (b 'B1) (b 'DBY) (c 'DCZ)))
|
|
(remove-assertion! sk (d (b 'BX) (b 'DBY) (c 'DCZ)))
|
|
(remove-assertion! sk (d (b 'B1) (b 'DBY) (c 'CX)))
|
|
(remove-assertion! sk (d (b 'B1) (b 'DBY) (c 'DCZ)))
|
|
(remove-assertion! sk (d (b 'BX) (b 'DBY) (c 'DCZ)))
|
|
(remove-assertion! sk (d (b 'B1) (b 'DBY) (c 'CX)))
|
|
;; sk
|
|
|
|
(remove-interest! sk i1)
|
|
|
|
(check-eq? (path-cmp '() '()) '=)
|
|
(check-eq? (path-cmp '(1 1) '(1 1)) '=)
|
|
(check-eq? (path-cmp '(2 2) '(2 2)) '=)
|
|
(check-eq? (path-cmp '(2 1) '(1 1)) '>)
|
|
(check-eq? (path-cmp '(1 1) '(2 1)) '<)
|
|
(check-eq? (path-cmp '(2 1) '(1 2)) '>)
|
|
(check-eq? (path-cmp '(1 2) '(2 1)) '<)
|
|
(check-eq? (path-cmp '(2) '(1 1)) '>)
|
|
(check-eq? (path-cmp '(1) '(2 1)) '<)
|
|
(check-eq? (path-cmp '(2) '(1 2)) '>)
|
|
(check-eq? (path-cmp '(1) '(2 1)) '<)
|
|
(check-eq? (path-cmp '(2 1) '(1)) '>)
|
|
(check-eq? (path-cmp '(1 1) '(2)) '<)
|
|
(check-eq? (path-cmp '(2 1) '(1)) '>)
|
|
(check-eq? (path-cmp '(1 2) '(2)) '<)
|
|
(check-eq? (path-cmp '(1 2) '(1 2)) '=)
|
|
(check-eq? (path-cmp '(1) '(1 2)) '<)
|
|
(check-eq? (path-cmp '(1 2) '(1)) '>)
|
|
)
|