diff options
| -rwxr-xr-x | bin/pangemma | 194 | ||||
| -rw-r--r-- | doc/code/pangemma.md | 15 |
2 files changed, 206 insertions, 3 deletions
diff --git a/bin/pangemma b/bin/pangemma index 399ed6f..e962ee5 100755 --- a/bin/pangemma +++ b/bin/pangemma @@ -8,6 +8,193 @@ exec guile --no-auto-compile -e main -s "$0" "$@" (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)) @@ -21,8 +208,11 @@ exec guile --no-auto-compile -e main -s "$0" "$@" (display "pangemma version 0.01\n") (exit))) (if help-wanted - (format #t "pangemma + (begin + (format #t "pangemma Usage: pangemma [options...] filename(s) -v --version Display version -h --help Display this help -")))) +") + (exit))) + (run))) diff --git a/doc/code/pangemma.md b/doc/code/pangemma.md index fe86f3f..a5e969b 100644 --- a/doc/code/pangemma.md +++ b/doc/code/pangemma.md @@ -90,5 +90,18 @@ Let's start with default GEMMA behaviour and create the first cells to get to ex We'll break down to inspecting cell levels after. The genofile cells contain a file name (string). When the file gets read we will capture the state in a file and carry the file name of the new file forward. -In this setup cells simply represent file names (for state). This allows us to simply read and write files in the C code. +In this setup cells simply represent file names (for state). +This allows us to simply read and write files in the C code. Later, when we wire up new propagators we may carry state in memory. The whole point of using this approach is that we really don't have to care! + +Our first simple implementation of the cell will simply contain a string referring to a file. +Cells can be work in progress and incrementally improved. + +## Create propagators + +A propagator contains a list of inputs and an output cell. So we wire up the graph by adding inputs to propagators. +Every propagator has state (too). I.e. it may be idle, computing and done. + +## The runner + +The runner visits the list of propagators and checks wether the inputs are complete and whether they have changed. On change computation has to happen updating the output cell. |