#!/bin/sh
# -*- mode: scheme; -*-
exec guile --no-auto-compile -e main -s "$0" "$@"
!#

(use-modules (ice-9 match)
             (ice-9 getopt-long)
             (srfi srfi-9)
             (srfi srfi-9 gnu))

(define-record-type <nothing>
  (make-nothing)
  %nothing?)
(define (print-nothing nothing port)
  (display "#<nothing>" port))
(set-record-type-printer! <nothing> print-nothing)
(define nothing (make-nothing))
(define (nothing? x) (eq? x nothing))

(define-record-type <contradiction>
  (make-contradiction details)
  contradiction?
  (details contradiction-details))

(define (print-contradiction contradiction port)
  (format port "#<contradiction ~a>"
          (contradiction-details contradiction)))
(set-record-type-printer! <contradiction> print-contradiction)

(define contradiction (make-contradiction nothing))

(define-record-type <relations>
  (%make-relations name parent children)
  relations?
  (name relations-name)
  (parent relations-parent)
  (children relations-children set-relations-children!))

(define (print-relations relations port)
  (match relations
    (($ <relations> name parent children)
     (format port "#<relations ~a ↑ ~a ↓ ~a>"
             name parent children))))
(set-record-type-printer! <relations> print-relations)

(define current-parent (make-parameter #f))

(define (make-relations name)
  (%make-relations name (current-parent) '()))

(define (add-child! parent child)
  (when parent
    (set-relations-children! parent (cons child (relations-children parent)))))

(define-record-type <cell>
  (%make-cell relations neighbors content strongest
              equivalent? merge find-strongest handle-contradiction)
  cell?
  (relations cell-relations)
  (neighbors cell-neighbors set-cell-neighbors!)
  (content cell-content set-cell-content!)
  (strongest cell-strongest set-cell-strongest!)
  ;; Dispatch table:
  (equivalent? cell-equivalent?)
  (merge cell-merge)
  (find-strongest cell-find-strongest)
  (handle-contradiction cell-handle-contradiction))

(define (print-cell cell port)
  (match cell
    (($ <cell> ($ <relations> name) _ _ strongest)
     (display "#<cell " port)
     (display name port)
     (display " " port)
     (display strongest port)
     (display ">" port))))
(set-record-type-printer! <cell> print-cell)

(define-record-type <propagator>
  (%make-propagator relations inputs outputs activate)
  propagator?
  (relations propagator-relations)
  (inputs propagator-inputs)
  (outputs propagator-outputs)
  (activate propagator-activate))

(define (print-propagator propagator port)
  (match propagator
    (($ <propagator> ($ <relations> name) inputs outputs)
     (display "#<propagator " port)
     (display name port)
     (display " " port)
     (display inputs port)
     (display " -> " port)
     (display outputs port)
     (display ">" port))))
(set-record-type-printer! <propagator> print-propagator)

(define default-equivalent? equal?)
;; But what about partial information???
(define (default-merge old new) new)
(define (default-find-strongest content) content)
(define (default-handle-contradiction cell) (values))

(define* (make-cell name #:key
                    (equivalent? default-equivalent?)
                    (merge default-merge)
                    (find-strongest default-find-strongest)
                    (handle-contradiction default-handle-contradiction))
  (let ((cell (%make-cell (make-relations name) '() nothing nothing
                          equivalent? merge find-strongest
                          handle-contradiction)))
    (add-child! (current-parent) cell)
    cell))

(define (cell-name cell)
  (relations-name (cell-relations cell)))

(define (add-cell-neighbor! cell neighbor)
  (set-cell-neighbors! cell (lset-adjoin eq? (cell-neighbors cell) neighbor)))

(define (add-cell-content! cell new)
  (match cell
    (($ <cell> _ neighbors content strongest equivalent? merge
               find-strongest handle-contradiction)
     (let ((content* (merge content new)))
       (set-cell-content! cell content*)
       (let ((strongest* (find-strongest content*)))
         (cond
          ;; New strongest value is equivalent to the old one.  No need
          ;; to alert propagators.
          ((equivalent? strongest strongest*)
           (set-cell-strongest! cell strongest*))
          ;; Uh oh, a contradiction!  Call handler.
          ((contradiction? strongest*)
           (set-cell-strongest! cell strongest*)
           (handle-contradiction cell))
          ;; Strongest value has changed.  Alert the propagators!
          (else
           (set-cell-strongest! cell strongest*)
           (for-each alert-propagator! neighbors))))))))

(define (alert-propagator! propagator)
  (queue-task! (propagator-activate propagator)))

(define (make-propagator name inputs outputs activate)
  (let ((propagator (%make-propagator (make-relations name)
                                      inputs outputs activate)))
    (add-child! (current-parent) propagator)
    (for-each (lambda (cell)
                (add-cell-neighbor! cell propagator))
              inputs)
    (alert-propagator! propagator)
    propagator))

(define (unusable-value? x)
  (or (nothing? x) (contradiction? x)))

(define (primitive-propagator name f)
  (match-lambda*
    ((inputs ... output)
     (define (activate)
       (let ((args (map cell-strongest inputs)))
         (unless (any unusable-value? args)
           (add-cell-content! output (apply f args)))))
     (make-propagator name inputs (list output) activate))))

(define (compound-propagator name inputs outputs build)
  (let ((built? #f))
    (define (maybe-build)
      (unless (or built?
                  (and (not (null? inputs))
                       (every unusable-value? (map cell-strongest inputs))))
        (parameterize ((current-parent (propagator-relations propagator)))
          (build)
          (set! built? #t))))
    (define propagator (make-propagator name inputs outputs maybe-build))
    propagator))

(define (constraint-propagator name cells build)
  (compound-propagator name cells cells build))


(define (run)
  (begin
    (display "START")
    (define a (make-cell "a"))
    (define b (make-cell "b"))
    (define c (make-cell "c"))
    (define d (make-cell "d"))
    (define output (make-cell "none"))
    (add-cell-content! a 1)
    (define (activate) #f)
    (define p (primitive-propagator 'test activate))
    (display "END")
  ))

(define (main args)
  (let* [
         (option-spec '( (version (single-char #\v) (value #f))
                         (id      (value #t))
                         (help    (single-char #\h) (value #f))))
         (options (getopt-long args option-spec))
         (show-version (option-ref options 'version #f))
         (help-wanted (option-ref options 'help #f))]
    (if show-version
        (begin
          (display "pangemma version 0.01\n")
          (exit)))
    (if help-wanted
        (begin
          (format #t "pangemma
Usage: pangemma [options...] filename(s)
  -v --version       Display version
  -h --help          Display this help
")
          (exit)))
    (run)))