#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)) '>)
  )
