Just have successful printout messages for save and load right now

;The Adventure Engine
;Copyright (c) 2012-2016, Joshua Scoggins
;All rights reserved.
;
;Redistribution and use in source and binary forms, with or without
;modification, are permitted provided that the following conditions are met:
;    * Redistributions of source code must retain the above copyright
;      notice, this list of conditions and the following disclaimer.
;    * Redistributions in binary form must reproduce the above copyright
;      notice, this list of conditions and the following disclaimer in the
;      documentation and/or other materials provided with the distribution.
;    * Neither the name of The Adventure Engine nor the
;      names of its contributors may be used to endorse or promote products
;      derived from this software without specific prior written permission.
;
;THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
;ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;DISCLAIMED. IN NO EVENT SHALL Joshua Scoggins BE LIABLE FOR ANY
;DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
;(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
;LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
;ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;------------------------------------------------------------------------------
; The user input prompt, located in the prompt module
;------------------------------------------------------------------------------
(defmodule prompt
           (import constants
                   defglobal
                   ?ALL)
           (export defclass
                   input-state))

(defclass prompt::input-state
  (is-a USER)
  (slot should-prompt
        (type SYMBOL)
        (allowed-symbols TRUE
                         FALSE))
  (slot processed-input
        (type SYMBOL)
        (allowed-symbols FALSE
                         TRUE))
  (slot prompt
        (type STRING)
        (storage local)
        (visibility public)
        (default ?NONE))
  (slot raw-input
        (type STRING)
        (default-dynamic ""))
  (multislot input
             (visibility public)))

(definstances prompt::initialization-of-input-state
              (of input-state
                  (prompt "> ")))

(defrule prompt::read-input
         "Read input from the end user"
         (declare (salience ?*absolute-first-priority*))
         ?f <- (object (is-a input-state)
                       (should-prompt TRUE)
                       (prompt ?prompt))
         =>
         (printout ?*router-out* ?prompt tab)
         (modify-instance ?f
                          (should-prompt FALSE)
                          (processed-input FALSE)
                          (raw-input (string-trim (bind ?rinput
                                                        (readline))))
                          (input (explode$ ?rinput))))

(defrule prompt::core-keyword:quit
         (declare (salience ?*absolute-first-priority*))
         ?f <- (object (is-a input-state)
                       (should-prompt FALSE)
                       (input quit))
         =>
         (unmake-instance ?f))

(defrule prompt::core-keyword:save
         (declare (salience ?*absolute-first-priority*))
         ?f <- (object (is-a input-state)
                       (should-prompt FALSE)
                       (input save ?path))
         =>
         (modify-instance ?f
                          (processed-input TRUE))
         ;TODO: insert save code here
         (printout ?*router-out*
                   tab "Successfully saved state to " ?path crlf))

(defrule prompt::core-keyword:load
         (declare (salience ?*absolute-first-priority*))
         ?f <- (object (is-a input-state)
                       (should-prompt FALSE)
                       (input load ?path))
         =>
         (modify-instance ?f (processed-input TRUE))
         ;TODO: insert load code here
         (printout ?*router-out*
                   tab "Successfully loaded state from " ?path crlf))

(defrule prompt::unknown-keyword
         "This is a fallthrough state when it wasn't possible to process the input with another rule"
         (declare (salience ?*after-normal-priority*))
         (object (is-a input-state)
                 (should-prompt FALSE)
                 (processed-input FALSE)
                 (raw-input ?input))
         =>
         (printout ?*router-out*
                   tab ?*unknown-input-message* " \"" ?input "\"" crlf))

(defrule prompt::reset-input
         (declare (salience ?*absolute-last-priority*))
         ?f <- (object (is-a input-state)
                       (should-prompt FALSE))
         =>
         (modify-instance ?f
                          (should-prompt TRUE)))

;The Adventure Engine
;Copyright (c) 2012-2016, Joshua Scoggins
;All rights reserved.
;
;Redistribution and use in source and binary forms, with or without
;modification, are permitted provided that the following conditions are met:
;    * Redistributions of source code must retain the above copyright
;      notice, this list of conditions and the following disclaimer.
;    * Redistributions in binary form must reproduce the above copyright
;      notice, this list of conditions and the following disclaimer in the
;      documentation and/or other materials provided with the distribution.
;    * Neither the name of The Adventure Engine nor the
;      names of its contributors may be used to endorse or promote products
;      derived from this software without specific prior written permission.
;
;THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
;ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;DISCLAIMED. IN NO EVENT SHALL Joshua Scoggins BE LIABLE FOR ANY
;DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
;(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
;LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
;ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;------------------------------------------------------------------------------
; The user input prompt, located in the prompt module
;------------------------------------------------------------------------------
(defmodule prompt
           (import constants
                   defglobal
                   ?ALL)
           (export defclass
                   input-state))

(defclass prompt::input-state
  (is-a USER)
  (slot should-prompt
        (type SYMBOL)
        (allowed-symbols TRUE
                         FALSE))
  (slot processed-input
        (type SYMBOL)
        (allowed-symbols FALSE
                         TRUE))
  (slot prompt
        (type STRING)
        (storage local)
        (visibility public)
        (default ?NONE))
  (slot raw-input
        (type STRING)
        (default-dynamic ""))
  (multislot input
             (visibility public)))

(definstances prompt::initialization-of-input-state
              (of input-state
                  (prompt "> ")))

(defrule prompt::read-input
         "Read input from the end user"
         (declare (salience ?*absolute-first-priority*))
         ?f <- (object (is-a input-state)
                       (should-prompt TRUE)
                       (prompt ?prompt))
         =>
         (printout ?*router-out* ?prompt tab)
         (modify-instance ?f
                          (should-prompt FALSE)
                          (processed-input FALSE)
                          (raw-input (bind ?rinput (readline)))
                          (input (explode$ ?rinput))))

(defrule prompt::core-keyword:quit
         (declare (salience ?*before-normal-priority*))
         ?f <- (object (is-a input-state)
                       (should-prompt FALSE)
                       (input quit))
         =>
         (unmake-instance ?f))

(defrule prompt::unknown-keyword
         "This is a fallthrough state when it wasn't possible to process the input with another rule"
         (declare (salience ?*after-normal-priority*))
         (object (is-a input-state)
                 (should-prompt FALSE)
                 (processed-input FALSE)
                 (raw-input ?input))
         =>
         (printout ?*router-out*
                   tab ?*unknown-input-message* " \"" ?input "\"" crlf))

(defrule prompt::reset-input
         (declare (salience ?*absolute-last-priority*))
         ?f <- (object (is-a input-state)
                       (should-prompt FALSE))
         =>
         (modify-instance ?f
                          (should-prompt TRUE)))


Fixed incorrect slot names in WavefrontPreInitialization.clp

I also reformatted the Left Hand Sides of the rules to be more in line with my
new rule scheme of having each slot on its own line

;------------------------------------------------------------------------------
;Copyright (c) 2012, Joshua Scoggins
;All rights reserved.
;
;Redistribution and use in source and binary forms, with or without
;modification, are permitted provided that the following conditions are met:
;    * Redistributions of source code must retain the above copyright
;      notice, this list of conditions and the following disclaimer.
;    * Redistributions in binary form must reproduce the above copyright
;      notice, this list of conditions and the following disclaimer in the
;      documentation and/or other materials provided with the distribution.
;    * Neither the name of Joshua Scoggins nor the
;      names of its contributors may be used to endorse or promote products
;      derived from this software without specific prior written permission.
;
;THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
;ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;DISCLAIMED. IN NO EVENT SHALL Joshua Scoggins BE LIABLE FOR ANY
;DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
;(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
;LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
;ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-pre-init::generate-wavefront-object
         (declare (salience 3))
         ?msg <- (message (to wavefront-scheduling)
                          (action can-wavefront-schedule)
                          (arguments ?p))
         (not (exists (object (is-a Wavefront)
                              (parent ?p))))
         =>
         (retract ?msg)
         (make-instance of Wavefront
                        (parent ?p)))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-pre-init::retract-wavefront-creation-action
         (declare (salience 3))
         ?msg <- (message (to wavefront-scheduling)
                          (action can-wavefront-schedule)
                          (arguments ?p))
         (exists (object (is-a Wavefront)
                         (parent ?p)))
         =>
         (retract ?msg))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-pre-init::assert-add-block-to-wavefront
         (declare (salience 2))
         (object (is-a Wavefront)
                 (parent ?r))
         (object (is-a Region)
                 (id ?r)
                 (Entrances $? ?e $?))
         (object (is-a BasicBlock)
                 (id ?e)
                 (parent ?r))
         =>
         (assert (Add ?e to wavefront for ?r)))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-pre-init::assert-add-region-to-wavefront
         (declare (salience 2))
         (object (is-a Wavefront)
                 (parent ?r))
         (object (is-a Region)
                 (id ?r)
                 (Entrances $? ?e $?))
         (object (is-a BasicBlock)
                 (id ?e)
                 (parent ~?r))
         (object (is-a Region)
                 (parent ?r)
                 (Entrances $? ?e $?)
                 (id ?q))
         =>
         (assert (Add ?q to wavefront for ?r)))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-pre-init::convert-single-single=>multi
         (declare (salience 1))
         ?f0 <- (Add ?v0 to wavefront for ?r)
         ?f1 <- (Add ?v1&~?v0 to wavefront for ?r)
         =>
         (retract ?f0 ?f1)
         (assert (In wavefront ?r add ?v0 ?v1)))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-pre-init::convert-multi-multi=>multi
         (declare (salience 1))
         ?f0 <- (In wavefront ?r add $?a)
         ?f1 <- (In wavefront ?r add $?b)
         (test (neq ?f0 ?f1))
         =>
         (retract ?f0 ?f1)
         (assert (In wavefront ?r add $?a $?b)))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-pre-init::convert-single=>multi
         (declare (salience 1))
         ?f0 <- (Add ?v0 to wavefront for ?r)
         =>
         (retract ?f0)
         (assert (In wavefront ?r add ?v0)))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-pre-init::construct-wavefront-for-region
         (declare (salience -1))
         ?f <- (In wavefront ?r add $?w)
         ?wave <- (object (is-a Wavefront)
                          (parent ?r))
         =>
         (retract ?f)
         (modify-instance ?wave (contents $?w)))
;------------------------------------------------------------------------------

;------------------------------------------------------------------------------
;Copyright (c) 2012, Joshua Scoggins
;All rights reserved.
;
;Redistribution and use in source and binary forms, with or without
;modification, are permitted provided that the following conditions are met:
;    * Redistributions of source code must retain the above copyright
;      notice, this list of conditions and the following disclaimer.
;    * Redistributions in binary form must reproduce the above copyright
;      notice, this list of conditions and the following disclaimer in the
;      documentation and/or other materials provided with the distribution.
;    * Neither the name of Joshua Scoggins nor the
;      names of its contributors may be used to endorse or promote products
;      derived from this software without specific prior written permission.
;
;THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
;ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;DISCLAIMED. IN NO EVENT SHALL Joshua Scoggins BE LIABLE FOR ANY
;DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
;(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
;LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
;ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-pre-init::generate-wavefront-object
         (declare (salience 3))
         ?msg <- (message (to wavefront-scheduling)
                          (action can-wavefront-schedule)
                          (argument ?p))
         (not (exists (object (is-a Wavefront) (parent ?p))))
         =>
         (retract ?msg)
         (make-instance of Wavefront (parent ?p)))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-pre-init::retract-wavefront-creation-action
         (declare (salience 3))
         ?msg <- (message (to wavefront-scheduling)
                          (action can-wavefront-schedule)
                          (argument ?p))
         (exists (object (is-a Wavefront) (parent ?p)))
         =>
         (retract ?msg))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-pre-init::assert-add-block-to-wavefront
         (declare (salience 2))
         (object (is-a Wavefront) (parent ?r))
         (object (is-a Region) (id ?r) (Entrances $? ?e $?))
         (object (is-a BasicBlock) (id ?e) (parent ?r))
         =>
         (assert (Add ?e to wavefront for ?r)))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-pre-init::assert-add-region-to-wavefront
         (declare (salience 2))
         (object (is-a Wavefront) (parent ?r))
         (object (is-a Region) (id ?r) (Entrances $? ?e $?))
         (object (is-a BasicBlock) (id ?e) (parent ~?r))
         (object (is-a Region) (parent ?r) (Entrances $? ?e $?) (id ?q))
         =>
         (assert (Add ?q to wavefront for ?r)))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-pre-init::convert-single-single=>multi
         (declare (salience 1))
         ;(Stage WavefrontInit $?)
         ?f0 <- (Add ?v0 to wavefront for ?r)
         ?f1 <- (Add ?v1&~?v0 to wavefront for ?r)
         ;(test (neq ?f0 ?f1))
         =>
         (retract ?f0 ?f1)
         (assert (In wavefront ?r add ?v0 ?v1)))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-pre-init::convert-multi-multi=>multi
         (declare (salience 1))
         ?f0 <- (In wavefront ?r add $?a)
         ?f1 <- (In wavefront ?r add $?b)
         (test (neq ?f0 ?f1))
         =>
         (retract ?f0 ?f1)
         (assert (In wavefront ?r add $?a $?b)))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-pre-init::convert-single=>multi
         (declare (salience 1))
         ?f0 <- (Add ?v0 to wavefront for ?r)
         =>
         (retract ?f0)
         (assert (In wavefront ?r add ?v0)))
;------------------------------------------------------------------------------
(defrule wavefront-scheduling-pre-init::construct-wavefront-for-region
         (declare (salience -1))
         ?f <- (In wavefront ?r add $?w)
         ?wave <- (object (is-a Wavefront) (parent ?r))
         =>
         (retract ?f)
         (modify-instance ?wave (contents $?w)))
;------------------------------------------------------------------------------


Finished the basic assembler

Finished the basic assembler

(load* (proton: /lib/core.clp))
(defglobal MAIN
           ?*instruction-list* = (create$ nop add sub mul div mod rightshift
                                          leftshift binaryand binaryor
                                          binarynot eq neq gt lt load store
                                          branch set call ret)

           ?*registers* = (create$ r0 r1 r2 r3 r4 r5 r6 r7 r8 r9 r10 r11 r12 r13
                                   r14 r15 r16 r17 r18 r19 r20 r21 r22 r23 r24
                                   r25 r26 r27 r28 r29 r30 r31 r32 r33 r34 r35
                                   r36 r37 r38 r39 r40 r41 r42 r43 r44 r45 r46
                                   r47 r48 r49 r50 r51 r52 r53 r54 r55 r56 r57
                                   r58 r59 r60 r61 r62 r63 r64 r65 r66 r67 r68
                                   r69 r70 r71 r72 r73 r74 r75 r76 r77 r78 r79
                                   r80 r81 r82 r83 r84 r85 r86 r87 r88 r89 r90
                                   r91 r92 r93 r94 r95 r96 r97 r98 r99 r100
                                   r101 r102 r103 pi3 pi2 pi1 pi0 pfalse ptrue
                                   ps7 ps6 ps5 ps4 ps3 ps2 ps1 ps0 po0 po1 pfci
                                   ra pc cc rc pid true false))
(defgeneric translate/instruction)
(defgeneric translate/register)

(defmethod translate/instruction
  ((?index INTEGER (= ?index 254)))
  platform)
(defmethod translate/instruction
  ((?index INTEGER (= ?index 255)))
  terminate)

(defmethod translate/instruction
  ((?index INTEGER))
  (nth$ ?index ?*instruction-list*))

(defmethod translate/instruction
  ((?symbol LEXEME (eq ?symbol platform)))
  254)
(defmethod translate/instruction
  ((?symbol LEXEME (eq ?symbol terminate)))
  255)

(defmethod translate/instruction
  ((?symbol LEXEME))
  (member$ ?symbol ?*instruction-list*))

(defmethod translate/register
  ((?index INTEGER))
  (nth$ ?index ?*registers*))

(defmethod translate/register
  ((?symbol LEXEME))
  (member$ ?symbol ?*registers*))

; syntax of an instruction is
; predicate op dest0 dest1 <- src0 src1
; predicate op dest0 <- src0 src1
; predicate op dest0 <- value
; predicate op dest0
; predicate op <- value
; predicate op

(defrule parse-input
         (initial-fact)
         =>
         (assert (parse input 1 (readline))))

(defrule done-parsing
         ?f <- (parse input ? EOF)
         =>
         (retract ?f))

(defrule continue-parsing
         ?f <- (parse input ?n ?line&~EOF)
         =>
         (retract ?f)
         (assert (instruction ?n (explode$ ?line))
                 (parse input (+ ?n 1) (readline))))

(defrule eliminate-parens
         (declare (salience 3))
         ?f <- (instruction ?n "(" ?predicate ")" $?rest)
         =>
         (retract ?f)
         (assert (instruction ?n ?predicate $?rest)))
(defrule parse-dual-result-instruction
         (declare (salience 2))
         ?f <- (instruction ? ?predicate ?op ?d0 ?d1 <- ?s0 ?s1)
         (test (not (neq ?op eq neq gt lt)))
         =>
         (retract ?f)
         (put-char t (translate/register ?predicate))
         (put-char t (translate/instruction ?op))
         (put-char t (translate/register ?d0))
         (put-char t (translate/register ?d1))
         (put-char t (translate/register ?s0))
         (put-char t (translate/register ?s1))
         (put-char t 0)
         (put-char t 0))

(defrule parse-single-result-instruction:dual-input
         (declare (salience 2))
         ?f <- (instruction ? ?predicate ?op ?d0 <- ?s0 ?s1)
         (test (not (neq ?op add sub mul div mod rightshift
                         leftshift binaryor binaryand)))
         =>
         (retract ?f)
         (put-char t (translate/register ?predicate))
         (put-char t (translate/instruction ?op))
         (put-char t (translate/register ?d0))
         (put-char t 0)
         (put-char t (translate/register ?s0))
         (put-char t (translate/register ?s1))
         (put-char t 0)
         (put-char t 0))

(defrule parse-single-result:single-input:binarynot
         (declare (salience 2))
         ?f <- (instruction ? ?predicate ?op ?dest <- ?value)
         (test (not (neq ?op load store binarynot)))
         =>
         (retract ?f)
         (put-char t (translate/register ?predicate))
         (put-char t (translate/instruction binarynot))
         (put-char t (translate/register ?dest))
         (put-char t 0)
         (put-char t (translate/register ?value))
         (put-char t 0)
         (put-char t 0)
         (put-char t 0))

(defrule parse-single:set
         (declare (salience 2))
         ?f <- (instruction ? ?predicate set ?dest <- ?value)
         =>
         (retract ?f)
         (put-char t (translate/register ?predicate))
         (put-char t (translate/instruction set))
         (put-char t (translate/register ?dest))
         (put-char t 0)
         (put-char t 0)
         (put-char t 0)
         (put-char t 0)
         (put-char t 0)
         (progn$ (?a (slice8 ?value))
                 (put-char t ?a)))

(defrule parse-none
         (declare (salience 2))
         ?f <- (instruction ? ?predicate ?op)
         (test (not (neq ?op nop ret platform terminate)))
         =>
         (retract ?f)
         (put-char t (translate/register ?predicate))
         (put-char t (translate/instruction ?op))
         (put-char t 0)
         (put-char t 0)
         (put-char t 0)
         (put-char t 0)
         (put-char t 0)
         (put-char t 0))

(defrule parse-call
         (declare (salience 2))
         ?f <- (instruction ? ?predicate call ?reg)
         =>
         (retract ?f)
         (put-char t (translate/register ?predicate))
         (put-char t (translate/instruction call))
         (put-char t 0)
         (put-char t 0)
         (put-char t (translate/register ?reg))
         (put-char t 0)
         (put-char t 0)
         (put-char t 0))

(defrule parse-branch
         (declare (salience 2))
         ?f <- (instruction ? ?predicate branch ?value)
         =>
         (retract ?f)
         (put-char t (translate/register ?predicate))
         (put-char t (translate/instruction branch))
         (put-char t 0)
         (put-char t 0)
         (put-char t 0)
         (put-char t 0)
         (put-char t 0)
         (put-char t 0)
         (progn$ (?a (slice8 ?value))
                 (put-char t ?a)))
(defrule skip-empty-lines
         (declare (salience 3))
         ?f <- (instruction ?)
         =>
         (retract ?f))
(defrule unknown-instruction
         (declare (salience 1))
         ?f <- (instruction ?line $?symbols)
         =>
         (retract ?f)
         (format werror "ERROR: unknown instruction on line %d%n%t%s%n" ?line
                 (implode$ $?symbols))
         (exit 1))

;TODO: continue
(batch* (proton: /lib/reset-run-exit.clp))

(defglobal MAIN
			  ?*instruction-list* = (create$ nop add sub mul div mod rightshift
														leftshift binaryand binaryor
														binarynot eq neq gt lt load store
														branch set call ret)

			  ?*registers* = (create$ r0 r1 r2 r3 r4 r5 r6 r7 r8 r9 r10 r11 r12 r13
											  r14 r15 r16 r17 r18 r19 r20 r21 r22 r23 r24
											  r25 r26 r27 r28 r29 r30 r31 r32 r33 r34 r35
											  r36 r37 r38 r39 r40 r41 r42 r43 r44 r45 r46
											  r47 r48 r49 r50 r51 r52 r53 r54 r55 r56 r57
											  r58 r59 r60 r61 r62 r63 r64 r65 r66 r67 r68
											  r69 r70 r71 r72 r73 r74 r75 r76 r77 r78 r79
											  r80 r81 r82 r83 r84 r85 r86 r87 r88 r89 r90
											  r91 r92 r93 r94 r95 r96 r97 r98 r99 r100
											  r101 r102 r103 pi3 pi2 pi1 pi0 pfalse ptrue
											  ps7 ps6 ps5 ps4 ps3 ps2 ps1 ps0 po0 po1 pfci
											  ra pc cc rc pid true false))
(defgeneric translate/instruction)
(defgeneric translate/register)

(defmethod translate/instruction
  ((?index INTEGER (= ?index 254)))
  platform)
(defmethod translate/instruction
  ((?index INTEGER (= ?index 255)))
  termnate)

(defmethod translate/instruction
  ((?index INTEGER))
  (nth$ ?index ?*instruction-list*))

(defmethod translate/instruction
  ((?symbol LEXEME (eq ?symbol platform)))
  254)
(defmethod translate/instruction
  ((?symbol LEXEME (eq ?symbol terminate)))
  255)
(defmethod translate/instruction
  ((?symbol LEXEME))
  (member$ ?symbol ?*instruction-list*))

(defmethod translate/register
  ((?index INTEGER))
  (nth$ ?index ?*registers*))

(defmethod translate/register
  ((?symbol LEXEME))
  (member$ ?symbol ?*registers*))

; syntax of an instruction is
; predicate op dest0 dest1 <- src0 src1
; predicate op dest0 <- src0 src1
; predicate op dest0 <- value
; predicate op dest0
; predicate op <- value
; predicate op

(defrule parse-dual-result-instruction
			(declare (salience 1))
			?f <- (instruction ?predicate ?op ?d0 ?d1 <- ?s0 ?s1)
			(test (not (neq ?op eq neq gt lt)))
			=>
			(retract ?f)
			(put-char t (translate/register ?predicate))
			(put-char t (translate/instruction ?op))
			(put-char t (translate/register ?d0))
			(put-char t (translate/register ?d1))
			(put-char t (translate/register ?s0))
			(put-char t (translate/register ?s1))
			(put-char t 0)
			(put-char t 0))

(defrule parse-single-result-instruction:dual-input
			(declare (salience 1))
			?f <- (instruction ?predicate ?op ?d0 <- ?s0 ?s1)
			(test (not (neq ?op add sub mul div mod rightshift
								 leftshift binaryor binaryand)))
			=>
			(retract ?f)
			(put-char t (translate/register ?predicate))
			(put-char t (translate/instruction ?op))
			(put-char t (translate/register ?d0))
			(put-char t 0)
			(put-char t (translate/register ?s0))
			(put-char t (translate/register ?s1))
			(put-char t 0)
			(put-char t 0))

(defrule parse-single-result:single-input:binarynot
			(declare (salience 1))
			?f <- (instruction ?predicate binarynot ?dest <- ?value)
			=>
			(retract ?f)
			(put-char t (translate/register ?predicate))
			(put-char t (translate/instruction binarynot))
			(put-char t (translate/register ?op))
			(put-char t 0)
			(put-char t (translate/register ?value))
			(put-char t 0)
			(put-char t 0)
			(put-char t 0))
;TODO: continue


Added improved menu handling

Added improved menu handling

(defclass native-pointer
  (is-a USER)
  (role abstract)
  (slot pointer-class
        (type LEXEME)
        (visibility public)
        (access read-only)
        (default nil))
  (slot pointer
        (type EXTERNAL-ADDRESS)
        (storage local)
        (visibility public))
  (message-handler init around)
  (message-handler build-pointer primary)
  (message-handler get-native-arguments primary))

(defmessage-handler native-pointer init around
                    ()
                    (call-next-handler)
                    (send ?self build-pointer))

(defmessage-handler native-pointer build-pointer primary
                    ()
                    (bind ?self:pointer
                          (new (dynamic-get pointer-class)
                               (expand$ (send ?self get-native-arguments)))))

(defclass point
  (is-a native-pointer)
  (role concrete)
  (pattern-match reactive)
  (slot pointer-class
        (source composite)
        (default Point))
  (slot x
        (type INTEGER)
        (range 0 ?VARIABLE)
        (visibility public)
        (storage local)
        (default ?NONE))
  (slot y
        (type INTEGER)
        (range 0 ?VARIABLE)
        (visibility public)
        (storage local)
        (default ?NONE))
  (message-handler get-native-arguments primary))

(defmessage-handler point get-native-arguments primary ()
                    (create$ ?self:x ?self:y))
(definstances default-points
              (ZP of point
                  (x 0)
                  (y 0)))
(defclass rectangle
  (is-a native-pointer)
  (role concrete)
  (pattern-match reactive)
  (slot pointer-class
        (source composite)
        (default Rectangle))
  (slot x
        (type INTEGER)
        (range 0 ?VARIABLE)
        (visibility public)
        (storage local)
        (default ?NONE))
  (slot y
        (type INTEGER)
        (range 0 ?VARIABLE)
        (visibility public)
        (storage local)
        (default ?NONE))
  (slot bx
        (type INTEGER)
        (range 0 ?VARIABLE)
        (visibility public)
        (storage local)
        (default ?NONE))
  (slot by
        (type INTEGER)
        (range 0 ?VARIABLE)
        (visibility public)
        (storage local)
        (default ?NONE))
  (message-handler get-native-arguments primary))

(defmessage-handler rectangle get-native-arguments primary
                    ()
                    (create$ ?self:x ?self:y ?self:bx ?self:by))

(definstances default-rectangle-types
              (pixel of rectangle
                     (x 0)
                     (y 0)
                     (bx 1)
                     (by 1)))
(defclass color
  (is-a USER)
  (slot red
        (type INTEGER)
        (range 0 255)
        (visibility public))
  (slot green
        (type INTEGER)
        (range 0 255)
        (visibility public))
  (slot blue
        (type INTEGER)
        (range 0 255)
        (visibility public))
  (message-handler to-native-color primary))

(defmessage-handler color to-native-color primary
                    ()
                    (rgb-to-cmap ?self:red
                                 ?self:green
                                 ?self:blue))
(defclass image
  (is-a native-pointer)
  (slot pointer-class
        (source composite)
        (default Image))
  (slot rectangle
        (type INSTANCE)
        (allowed-classes rectangle)
        (storage local)
        (visibility public)
        (default ?NONE))
  (slot replicate
        (type SYMBOL)
        (allowed-symbols FALSE TRUE)
        (visibility public))
  (slot color
        (type INSTANCE INTEGER)
        (allowed-classes color)
        (storage local)
        (default-dynamic 0))
  (message-handler get-native-arguments primary))

(defmessage-handler image get-native-arguments primary
                    ()
                    (create$ (send ?self:rectangle get-pointer)
                             (if ?self:replicate then 1 else 0)
                             (if (instancep ?self:color) then
                               (send ?self:color to-native-color)
                               else
                               ?self:color)))
(defmethod screen/draw
  ((?r rectangle)
   (?src image)
   (?mask image)
   (?p point))
  (screen/draw (send ?r get-pointer)
               (send ?src get-pointer)
               (send ?mask get-pointer)
               (send ?p get-pointer)))

(defmethod screen/draw
  ((?r rectangle)
   (?src image)
   (?p point))
  (screen/draw (send ?r get-pointer)
               (send ?src get-pointer)
               (new Image)
               (send ?p get-pointer)))

(defglobal MAIN
           ?*default-screen-flush-behavior* = TRUE)
(defmethod screen/flush
  ((?vis SYMBOL (not (neq ?vis TRUE FALSE))))
  (screen/flush (if ?vis then 1 else 0)))

(defmethod screen/flush
  ()
  (screen/flush ?*default-screen-flush-behavior*))

(defmethod screen/draw-text
  ((?p point)
   (?src image)
   (?sp point)
   (?str LEXEME))
  (screen/draw-text (send ?p get-pointer)
                    (send ?src get-pointer)
                    (send ?sp get-pointer)
                    ?str))

(defgeneric translate/kbd/query)
(defgeneric translate/mouse/buttons)
(defgeneric bool)
(defmethod bool ((?number INTEGER)) (if (= ?number 0) then FALSE else TRUE))

(defmethod translate/mouse/buttons
  ()
  ; Mouse combinations
  ; m.buttons & 1 => left-click
  ; m.buttons & 2 => middle-click
  ; m.buttons & 3 => left + middle
  ; m.buttons & 4 => right-click
  ; m.buttons & 5 => left + right
  ; m.buttons & 6 => middle + right
  ; m.buttons & 7 => left + middle + right
  (bind ?z (mouse/buttons))
  (return (create$
            (if (bool (binary-and ?z 1)) then button1 else (create$))
            (if (bool (binary-and ?z 2)) then button2 else (create$))
            (if (bool (binary-and ?z 4)) then button3 else (create$)))))

(defmethod translate/kbd/query
  ()
  ; This method has to be defined by the programmer because it is application
  ; specific. By default, if we don't know what the value is then just return
  ; the original rune value.
  (bind ?rune (kbd/query))
  (return (switch ?rune
                  (case -1 then NIL)
                  (case 0 then NIL)
                  (case 27 then ESC)
                  (case 61454 then UP)
                  (case 63488 then DOWN) ; Plan9's down :/
                  (case 128 then DOWN) ; this is the value I get for down
                  (case 61457 then LEFT)
                  (case 61458 then RIGHT)
                  (default ?rune))))
(defclass mouse
  (is-a USER)
  (multislot position
             (type INTEGER)
             (create-accessor read))
  (multislot buttons
             (type SYMBOL)
             (create-accessor read))
  (multislot timestamp
             (type INTEGER)
             (create-accessor read))
  (message-handler query primary))

(defmessage-handler mouse query primary
                    ()
                    (bind ?out (mouse/query))
                    (if ?out then
                      (bind ?self:position (bind ?tmp (mouse/position)))
                      (bind ?self:buttons
                            (translate/mouse/buttons (mouse/buttons)))
                      (bind ?self:timestamp (mouse/timestamp)))
                    (return ?out))
(definstances mouse-object
              (mouse of mouse))

(defclass keyboard
  (is-a USER)
  (multislot keys
             (type SYMBOL INTEGER)
             (create-accessor read))
  (slot length
        (type INTEGER)
        (create-accessor read))
  ; behavior slots
  ; should we append to the list of keys?
  (slot append-on-query
        (type SYMBOL)
        (allowed-symbols FALSE TRUE))
  ; Should we attempt to convert from raw codes to symbols?
  (slot raw-keycodes
        (type SYMBOL)
        (allowed-symbols FALSE TRUE))
  (message-handler clear primary)
  (message-handler query primary))

(defmessage-handler keyboard clear primary
                    ()
                    (bind ?self:keys (create$))
                    (bind ?self:length 0))

(defmessage-handler keyboard query primary
                    "Get a key from the native runtime queue"
                    ()
                    (bind ?key (if ?self:raw-keycodes then
                                 (kbd/query)
                                 else
                                 (translate/kbd/query)))

                    (if ?self:append-on-query then
                      (slot-direct-insert$ keys
                                           (+ ?self:index 1)
                                           ?key)
                      else
                      (bind ?self:keys (create$ ?key)))
                    (bind ?self:length (+ ?self:length 1))
                    (return ?key))

(definstances keyboard-interface
              (keyboard of keyboard))

(defgeneric quickmenu)
(defgeneric quickmenu/show)
(defgeneric translate-menu-id)
(defclass menu
  (is-a native-pointer)
  (role concrete)
  (pattern-match reactive)
  (slot pointer-class
        (source composite)
        (default Menu))
  (multislot menu-entries
             (type LEXEME)
             (storage local)
             (visibility public)
             (default ?NONE))
  (message-handler get-native-arguments primary)
  (message-handler show-menu primary))

(defmessage-handler menu get-native-arguments primary
                    ()
                    ?self:menu-entries)
(defmessage-handler menu show-menu primary
                    "shows the target menu and translates it to the corresponding symbolic
                    representation"
                    (?button)
                    (translate-menu-id (menu/show ?self:pointer ?button)
                                       ?self:menu-elements))

(defmethod quickmenu/show
  "Construct a quick list and return a symbolic representation"
  ((?elements MULTIFIELD LEXEME)
   (?button INTEGER))
  (translate-menu-id (menu/show (quickmenu ?elements) ?button) ?elements))

(defmethod quickmenu
  "Defines a menu pointer without any associated object"
  (($?entries LEXEME))
  (quickmenu ?entries))

(defmethod quickmenu
  "Defines a menu pointer without any associated object"
  ((?entries MULTIFIELD LEXEME))
  (new menu (expand$ ?entries)))

(defmethod translate-menu-id
  "Translates numeric input from menu/show to symbolic representation"
  ((?id INTEGER (> ?id -1))
   (?elements MULTIFIELD LEXEME))
  ; We are one indexed while libevent is zero indexed
  (return (nth$ (+ ?id 1) ?elements)))

(defmethod translate-menu-id
  "Translates numeric input from menu/show to symbolic representation"
  ((?id INTEGER)
   ($?elements LEXEME))
  (translate-menu-id ?id ?elements))


waltz part running abouyt 10 minutes

waltz part running abouyt 10 minutes

;;; The Waltz Algorithm implemented using CLIPS
;;; The original source for the OPS5 benchmark suite is available
;;; at http://www.cs.utexas.edu/ftp/pub/ops5-benchmark-suite/

;;; The copyright notice from the original code:

;;; Copyright C 1991 Satoshi Nishiyama and the University of Texas at Austin
;;; anyone may copy and use this program the terms listed in the copyright
;;; notice in and covering the Communications of the ACM, the program is
;;; is not warranted to do anything

;;; Changes made for the CLIPS version
;;;
;;;   Reformatted code
;;;   Converted C code to deffunctions
;;;   Uses salience to obtain a number of rule firings consistent
;;;     with other rule engines running this benchmark

;;; ##########################################################################
;;; Deftemplates
;;;
;;; Lines have the lable line followed by the 2 points defining the line.
;;;
;;; Edges are like lines accept that they can be labeled, permanently labeled,
;;; and plotted.
;;;
;;; Junctions are defined by 4 points.  The basepoint is where the 3 (2) lines
;;; intersect.  The points p1, p2, p3 are the other endpoints of the lines at
;;; this junction
;;; ##########################################################################

(deftemplate stage
   (slot value))

(deftemplate line
   (slot p1 (type INTEGER))
   (slot p2 (type INTEGER)))

(deftemplate edge
   (slot p1 (type INTEGER))
   (slot p2 (type INTEGER))
   (slot joined (type BOOLEAN))
   (slot label)
   (slot plotted))

(deftemplate junction
   (slot p1 (type INTEGER))
   (slot p2 (type INTEGER))
   (slot p3 (type INTEGER))
   (slot base_point (type INTEGER))
   (slot jtype))

; ;;; #################################################################
; ;;; Deffunctions
; ;;;
; ;;; In the OPS5 version of this program, the following deffunctions
; ;;; were implemented in C code that needed to be linked with the OPS5
; ;;; interpreter. Using deffunctions allows the benchmark to be run
; ;;; without having to recompile and relink CLIPS with the C code used
; ;;; in the original benchmark. The performance impact of using
; ;;; deffunctions for this benchmark rather than C code is minimal.
; ;;; #################################################################

; (defglobal ?*MOD-NUM* = 100)

; ;;; *****
; ;;; atan2
; ;;; *****

; (deffunction atan2 (?y ?x)
;    (if (> ?x 0)
;       then
;       (return (atan (/ ?y ?x))))

;    (if (< ?x 0)
;       then
;       (return (- (atan (/ ?y ?x)) (pi))))

;    (if (> ?y 0) then
;       then
;       (return (pi)))

;    (if (< ?y 0)
;       then
;       (return (- 0 (pi))))

;    (return undefined))

; ;;; *****
; ;;; get-y
; ;;; *****

; (deffunction get-y (?val)
;    (mod ?val ?*MOD-NUM*))

; ;;; *****
; ;;; get-x
; ;;; *****

; (deffunction get-x (?val)
;    (integer (/ ?val ?*MOD-NUM*)))

; ;;; *********
; ;;; get-angle
; ;;; *********

; (deffunction get-angle (?p1 ?p2)
;    (bind ?delta-x (- (get-x ?p2) (get-x ?p1)))
;    (bind ?delta-y (- (get-y ?p2) (get-y ?p1)))
;    (if (= ?delta-x 0)
;       then
;        (if (> ?delta-y 0)
; 		  then (return (/ (pi) 2))
; 		  else (if (< ?delta-y 0) then (return (/ (pi) -2))))
;       else
;       (if (= ?delta-y 0)
;          then
;          (if (> ?delta-x 0)
;             then (return 0.0)
; 		    else (if (< ?delta-x 0) then return (pi)))
;          else
;          (return (atan2 ?delta-y ?delta-x)))))

; ;;; ***************
; ;;; inscribed-angle
; ;;; ***************

; (deffunction inscribed-angle (?basepoint ?p1 ?p2)

; 	;; Get the angle between line #1 and the origin and the angle
; 	;; between line #2 and the origin, and then subtract these values.

;    (bind ?angle1 (get-angle ?basepoint ?p1))
;    (bind ?angle2 (get-angle ?basepoint ?p2))
;    (bind ?temp (- ?angle1 ?angle2))

;    (if (< ?temp 0)
;       then (bind ?temp (- 0 ?temp)))

;    ;; We always want the smaller of the two angles inscribed, so
;    ;; if the answer is greater than 180 degrees, calculate the
;    ;; smaller angle and return it.

;    (if (> ?temp (pi))
;       then
;       (bind ?temp (- (* 2 (pi)) ?temp)))

;    (if (< ?temp 0)
;       then (return (- 0 ?temp)))

;    (return ?temp))

; ;;; ***************
; ;;; make-3-junction
; ;;; ***************

; (deffunction make-3-junction (?basepoint ?p1 ?p2 ?p3)
;    (bind ?angle12 (inscribed-angle ?basepoint ?p1 ?p2))
;    (bind ?angle13 (inscribed-angle ?basepoint ?p1 ?p3))
;    (bind ?angle23 (inscribed-angle ?basepoint ?p2 ?p3))

;    (bind ?sum1213 (+ ?angle12 ?angle13))
;    (bind ?sum1223 (+ ?angle12 ?angle23))
;    (bind ?sum1323 (+ ?angle13 ?angle23))

;    (if (< ?sum1213 ?sum1223)
;       then
;       (if (< ?sum1213 ?sum1323)
;          then
;          (bind ?sum ?sum1213)
;          (bind ?shaft ?p1)
;          (bind ?barb1 ?p2)
;          (bind ?barb2 ?p3)
;          else
;          (bind ?sum ?sum1323)
;          (bind ?shaft ?p3)
;          (bind ?barb1 ?p1)
;          (bind ?barb2 ?p2))
;       else
;       (if (< ?sum1223 ?sum1323)
;          then
;          (bind ?sum ?sum1223)
;          (bind ?shaft ?p2)
;          (bind ?barb1 ?p1)
;          (bind ?barb2 ?p3)
;          else
;          (bind ?sum ?sum1323)
;          (bind ?shaft ?p3)
;          (bind ?barb1 ?p1)
;          (bind ?barb2 ?p2)))

;    (bind ?delta (- ?sum (pi)))
;    (if (< ?delta 0)
;       then (bind ?delta (- 0 ?delta)))

;    (if (< ?delta 0.001)
;       then (bind ?jtype tee)
;       else
;       (if (> ?sum (pi))
;          then (bind ?jtype fork)
;          else (bind ?jtype arrow)))

;    (assert (junction (p1 (integer ?barb1))
;                      (p2 (integer ?shaft))
;                      (p3 (integer ?barb2))
;                      (base_point (integer ?basepoint))
;                      (jtype ?jtype))))

;;; ########
;;; Defrules
;;; ########

;;; *******************************************************
;;; begin: Our starting production. It checks to see if the
;;;   start flag is in WM, and if it is, it deletes it
;;; *******************************************************

(defrule begin
	?f1 <- (stage (value start))
	=>
	(assert (line (p1 0122) (p2 0107)))
	(assert (line (p1 0107) (p2 2207)))
	(assert (line (p1 2207) (p2 3204)))
	(assert (line (p1 3204) (p2 6404)))
	(assert (line (p1 2216) (p2 2207)))
	(assert (line (p1 3213) (p2 3204)))
	(assert (line (p1 2216) (p2 3213)))
	(assert (line (p1 0107) (p2 2601)))
	(assert (line (p1 2601) (p2 7401)))
	(assert (line (p1 6404) (p2 7401)))
	(assert (line (p1 3213) (p2 6413)))
	(assert (line (p1 6413) (p2 6404)))
	(assert (line (p1 7416) (p2 7401)))
	(assert (line (p1 5216) (p2 6413)))
	(assert (line (p1 2216) (p2 5216)))
	(assert (line (p1 0122) (p2 5222)))
	(assert (line (p1 5222) (p2 7416)))
	(assert (line (p1 5222) (p2 5216)))
	(modify ?f1 (value duplicateStage)))

;;; **********************************************************************
;;; reverse_edges: If the duplicate flag is set, and there is still a line
;;;   in WM, delete the line and add two edges. One edge runs from p1 to
;;;   p2 and the other runs from p2 to p1. We then plot the edge.
;;; **********************************************************************

(defrule reverse_edges
	(stage (value duplicateStage))
	?f2 <- (line (p1 ?p1) (p2 ?p2))
	=>
	(assert (edge (p1 ?p1) (p2 ?p2) (joined false)))
    (assert (edge (p1 ?p2) (p2 ?p1) (joined false)))
	(retract ?f2))

;;; **************************************************************************
;;; done_reversing: If the duplicating flag is set, and there are no more
;;;   lines, then remove the duplicating flag and set the make junctions flag.
;;; **************************************************************************

(defrule done_reversing
	(declare (salience -10))
	?f1 <- (stage (value duplicateStage))
	(not (line))
	=>
	(modify ?f1 (value detect_junctions)))

;;; *****************************************************************************
;;; make-3_junction: If three edges meet at a point and none of them have already
;;;   been joined in a junction, then make the corresponding jtype of junction and
;;;   label the edges joined.  This production calls make-3_junction to determine
;;;   what jtype of junction it is based on the angles inscribed by the
;;;   intersecting edges.
;;; *****************************************************************************

(defrule make-3_junction
	(declare (salience 10))
	(stage (value detect_junctions))
	?f2 <- (edge (p1 ?base_point) (p2 ?p1) (joined false))
	?f3 <- (edge (p1 ?base_point) (p2 ?p2&~?p1) (joined false))
	?f4 <- (edge (p1 ?base_point) (p2 ?p3&~?p1&~?p2) (joined false))
	=>
	(make-3-junction ?base_point ?p1 ?p2 ?p3)
	(modify ?f2 (joined true))
	(modify ?f3 (joined true))
	(modify ?f4 (joined true)))

;;; ******************************************************
;;; make_L: If two, and only two, edges meet that have not
;;;   already been joined, then the junction is an "L".
;;; ******************************************************

(defrule make_L
	(stage (value detect_junctions))
	?f2 <- (edge (p1 ?base_point) (p2 ?p2) (joined false))
	?f3 <- (edge (p1 ?base_point) (p2 ?p3&~?p2) (joined false))
	(not (edge (p1 ?base_point) (p2 ~?p2&~?p3)))
	=>
	(assert (junction (jtype L)
               		  (base_point ?base_point)
		              (p1 ?p2)
		              (p2 ?p3)))
	(modify ?f2 (joined true))
	(modify ?f3 (joined true)))

;;; ******************************************************************
;;; done_detecting: If the detect junctions flag is set, and there are
;;;   no more un_joined edges, set the find_initial_boundary flag.
;;; ******************************************************************

(defrule done_detecting
	(declare (salience -10))
	?f1 <- (stage (value detect_junctions))
	(not (edge (joined false)))
	=>
	(modify ?f1 (value find_initial_boundary)))

;;; ****************************************************
;;; initial_boundary_junction_L: If the initial boundary
;;;   junction is an L, then we know it's labelling
;;; ****************************************************

(defrule initial_boundary_junction_L
	?f1 <- (stage (value find_initial_boundary))
    (junction (jtype L)
              (base_point ?base_point)
              (p1 ?p1)
              (p2 ?p2))
	?f3 <- (edge (p1 ?base_point) (p2 ?p1))
	?f4 <- (edge (p1 ?base_point) (p2 ?p2))
    (not (junction (base_point ?bp&:(> ?bp ?base_point))))
	=>
    (modify ?f3 (label B))
	(modify ?f4 (label B))
	(modify ?f1 (value find_second_boundary)))

;;; ***************************************************
;;; initial_boundary_junction_arrow: Ditto for an arrow
;;; ***************************************************

(defrule initial_boundary_junction_arrow
	?f1 <- (stage (value find_initial_boundary))
	(junction (jtype arrow) (base_point ?bp) (p1 ?p1) (p2 ?p2) (p3 ?p3))
	?f3 <- (edge (p1 ?bp) (p2 ?p1))
	?f4 <- (edge (p1 ?bp) (p2 ?p2))
	?f5 <- (edge (p1 ?bp) (p2 ?p3))
	(not (junction (base_point ?base_point&:(> ?base_point ?bp))))
	=>
    (modify ?f3 (label B))
	(modify ?f4 (label +))
	(modify ?f5 (label B))
	(modify ?f1 (value find_second_boundary)))

;;; ***********************************************************************
;;; second_boundary_junction_L: If we have already found the first boundary
;;;   point, then find the second boundary point, and label it.
;;; ***********************************************************************

(defrule second_boundary_junction_L
	?f1 <- (stage (value find_second_boundary))
    (junction (jtype L) (base_point ?base_point) (p1 ?p1) (p2 ?p2))
	?f3 <- (edge (p1 ?base_point) (p2 ?p1))
	?f4 <- (edge (p1 ?base_point) (p2 ?p2))
    (not (junction (base_point ?bp&:(< ?bp ?base_point))))
	=>
    (modify ?f3 (label B))
    (modify ?f4 (label B))
    (modify ?f1 (value labeling)))

;;; ******************************
;;; second_boundary_junction_arrow
;;; ******************************

(defrule second_boundary_junction_arrow
	?f1 <- (stage (value find_second_boundary))
	(junction (jtype arrow) (base_point ?bp) (p1 ?p1) (p2 ?p2) (p3 ?p3))
	?f3 <- (edge (p1 ?bp) (p2 ?p1))
	?f4 <- (edge (p1 ?bp) (p2 ?p2))
	?f5 <- (edge (p1 ?bp) (p2 ?p3))
	(not (junction (base_point ?base_point&:(< ?base_point ?bp))))
	=>
    (modify ?f3 (label B))
	(modify ?f4 (label +))
	(modify ?f5 (label B))
	(modify ?f1 (value labeling)))

;;; **********************************************************************
;;; match_edge: If we have an edge whose label we already know definitely,
;;;   then label the corresponding edge in the other direction
;;; **********************************************************************

(defrule match_edge
	(stage (value labeling))
	?f2 <- (edge (p1 ?p1) (p2 ?p2) (label ?label& + | - | B))
	?f3 <- (edge (p1 ?p2) (p2 ?p1) (label nil))
	=>
	(modify ?f2 (plotted t))
	(modify ?f3 (label ?label) (plotted t)))

;;; The following productions propogate the possible labellings of the edges
;;; based on the labellings of edges incident on adjacent junctions.  Since
;;; from the initial boundary productions, we have determined the labellings of
;;; of atleast two junctions, this propogation will label all of the junctions
;;; with the possible labellings.  The search space is pruned due to filtering,
;;; i.e. - only label a junction in the ways physically possible based on the
;;; labellings of adjacent junctions.

;;; *******
;;; label_L
;;; *******
(defrule label_L
	(stage (value labeling))
	(junction (jtype L) (base_point ?p1))
	(edge (p1 ?p1) (p2 ?p2) (label + | -))
	?f4 <- (edge (p1 ?p1) (p2 ~?p2) (label nil))
	=>
	(modify ?f4 (label B)))

;;; ***********
;;; label_tee_A
;;; ***********

(defrule label_tee_A
	(declare (salience 5))
	(stage (value labeling))
	(junction (jtype tee) (base_point ?bp) (p1 ?p1) (p2 ?p2) (p3 ?p3))
	?f3 <- (edge (p1 ?bp) (p2 ?p1) (label nil))
	?f4 <- (edge (p1 ?bp) (p2 ?p3))
	=>
    (modify ?f3 (label B))
	(modify ?f4 (label B)))

;;; ***********
;;; label_tee_B
;;; ***********

(defrule label_tee_B
	(stage (value labeling))
	(junction (jtype tee) (base_point ?bp) (p1 ?p1) (p2 ?p2) (p3 ?p3))
	?f3 <- (edge (p1 ?bp) (p2 ?p1))
	?f4 <- (edge (p1 ?bp) (p2 ?p3) (label nil))
	=>
    (modify ?f3 (label B))
	(modify ?f4 (label B)))

;;; ************
;;; label_fork-1
;;; ************
(defrules
(label_fork-1
	(stage (value labeling))
	(junction (jtype fork) (base_point ?bp))
	(edge (p1 ?bp) (p2 ?p1) (label +))
	?f4 <- (edge (p1 ?bp) (p2 ?p2&~?p1) (label nil))
	?f5 <- (edge (p1 ?bp) (p2 ~?p2&~?p1))
	=>
	(modify ?f4 (label +))
	(modify ?f5 (label +)))

;;; ************
;;; label_fork-2
;;; ************

(label_fork-2
	(stage (value labeling))
	(junction (jtype fork) (base_point ?bp))
	(edge (p1 ?bp) (p2 ?p1) (label B))
	(edge (p1 ?bp) (p2 ?p2&~?p1) (label -))
	?f5 <- (edge (p1 ?bp) (p2 ~?p2&~?p1) (label nil))
	=>
	(modify ?f5 (label B)))

;;; ************
;;; label_fork-3
;;; ************

(label_fork-3
	(stage (value labeling))
	(junction (jtype fork) (base_point ?bp))
	(edge (p1 ?bp) (p2 ?p1) (label B))
	(edge (p1 ?bp) (p2 ?p2&~?p1) (label B))
	?f5 <- (edge (p1 ?bp) (p2 ~?p2&~?p1) (label nil))
	=>
	(modify ?f5 (label -)))

;;; ************
;;; label_fork-4
;;; ************

(label_fork-4
	(stage (value labeling))
	(junction (jtype fork) (base_point ?bp))
	(edge (p1 ?bp) (p2 ?p1) (label -))
	(edge (p1 ?bp) (p2 ?p2&~?p1) (label -))
	?f5 <- (edge (p1 ?bp) (p2 ~?p2&~?p1) (label nil))
	=>
	(modify ?f5 (label -)))

;;; **************
;;; label_arrow-1A
;;; **************
)

(defrules
(label_arrow-1A
	(declare (salience 5))
	(stage (value labeling))
	(junction (jtype arrow) (base_point ?bp) (p1 ?p1) (p2 ?p2) (p3 ?p3))
	(edge (p1 ?bp) (p2 ?p1) (label ?label& B | - ))
	?f4 <- (edge (p1 ?bp) (p2 ?p2) (label nil))
	?f5 <- (edge (p1 ?bp) (p2 ?p3))
	=>
	(modify ?f4 (label +))
	(modify ?f5 (label ?label)))

;;; **************
;;; label_arrow-1B
;;; **************

(label_arrow-1B
	(stage (value labeling))
	(junction (jtype arrow) (base_point ?bp) (p1 ?p1) (p2 ?p2) (p3 ?p3))
	(edge (p1 ?bp) (p2 ?p1) (label ?label& B | - ))
	?f4 <- (edge (p1 ?bp) (p2 ?p2))
	?f5 <- (edge (p1 ?bp) (p2 ?p3) (label nil))
	=>
	(modify ?f4 (label +))
	(modify ?f5 (label ?label)))

;;; **************
;;; label_arrow-2A
;;; **************

(label_arrow-2A
	(declare (salience 5))
	(stage (value labeling))
	(junction (jtype arrow) (base_point ?bp) (p1 ?p1) (p2 ?p2) (p3 ?p3))
	(edge (p1 ?bp) (p2 ?p3) (label ?label& B | - ))
	?f4 <- (edge (p1 ?bp) (p2 ?p2) (label nil))
	?f5 <- (edge (p1 ?bp) (p2 ?p1))
	=>
	(modify ?f4 (label +))
	(modify ?f5 (label ?label)))

;;; **************
;;; label_arrow-2B
;;; **************

(label_arrow-2B
	(stage (value labeling))
	(junction (jtype arrow) (base_point ?bp) (p1 ?p1) (p2 ?p2) (p3 ?p3))
	(edge (p1 ?bp) (p2 ?p3) (label ?label& B | - ))
	?f4 <- (edge (p1 ?bp) (p2 ?p2))
	?f5 <- (edge (p1 ?bp) (p2 ?p1) (label nil))
	=>
	(modify ?f4 (label +))
	(modify ?f5 (label ?label)))
)

;;; **************
;;; label_arrow-3A
;;; **************

(defrule label_arrow-3A
	(declare (salience 5))
	(stage (value labeling))
	(junction (jtype arrow) (base_point ?bp) (p1 ?p1) (p2 ?p2) (p3 ?p3))
	(edge (p1 ?bp) (p2 ?p1) (label +))
	?f4 <- (edge (p1 ?bp) (p2 ?p2) (label nil))
	?f5 <- (edge (p1 ?bp) (p2 ?p3))
	=>
	(modify ?f4 (label -))
	(modify ?f5 (label +)))

;;; **************
;;; label_arrow-3B
;;; **************

(defrule label_arrow-3B
	(stage (value labeling))
	(junction (jtype arrow) (base_point ?bp) (p1 ?p1) (p2 ?p2) (p3 ?p3))
	(edge (p1 ?bp) (p2 ?p1) (label +))
	?f4 <- (edge (p1 ?bp) (p2 ?p2))
	?f5 <- (edge (p1 ?bp) (p2 ?p3) (label nil))
	=>
	(modify ?f4 (label -))
	(modify ?f5 (label +)))

;;; **************
;;; label_arrow-4A
;;; **************

(defrule label_arrow-4A
	(declare (salience 5))
	(stage (value labeling))
	(junction (jtype arrow) (base_point ?bp) (p1 ?p1) (p2 ?p2) (p3 ?p3))
	(edge (p1 ?bp) (p2 ?p3) (label +))
	?f4 <- (edge (p1 ?bp) (p2 ?p2) (label nil))
	?f5 <- (edge (p1 ?bp) (p2 ?p1))
	=>
	(modify ?f4 (label -))
	(modify ?f5 (label +)))

;;; **************
;;; label_arrow-4B
;;; **************

(defrule label_arrow-4B
	(stage (value labeling))
	(junction (jtype arrow) (base_point ?bp) (p1 ?p1) (p2 ?p2) (p3 ?p3))
	(edge (p1 ?bp) (p2 ?p3) (label +))
	?f4 <- (edge (p1 ?bp) (p2 ?p2))
	?f5 <- (edge (p1 ?bp) (p2 ?p1) (label nil))
	=>
	(modify ?f4 (label -))
	(modify ?f5 (label +)))

;;; **************
;;; label_arrow-5A
;;; **************

(defrule label_arrow-5A
	(declare (salience 5))
	(stage (value labeling))
	(junction (jtype arrow) (base_point ?bp) (p1 ?p1) (p2 ?p2) (p3 ?p3))
	(edge (p1 ?bp) (p2 ?p2) (label -))
	?f4 <- (edge (p1 ?bp) (p2 ?p1))
	?f5 <- (edge (p1 ?bp) (p2 ?p3) (label nil))
	=>
	(modify ?f4 (label +))
	(modify ?f5 (label +)))

;;; **************
;;; label_arrow-5B
;;; **************

(defrule label_arrow-5B
	(stage (value labeling))
	(junction (jtype arrow) (base_point ?bp) (p1 ?p1) (p2 ?p2) (p3 ?p3))
	(edge (p1 ?bp) (p2 ?p2) (label -))
	?f4 <- (edge (p1 ?bp) (p2 ?p1) (label nil))
	?f5 <- (edge (p1 ?bp) (p2 ?p3))
	=>
	(modify ?f4 (label +))
	(modify ?f5 (label +)))

;;; *******************************************************************************
;;; done_labeling: The conflict resolution mechanism will only execute a production
;;;   if no productions that are more complicated are satisfied.  This production
;;;   is simple, so all of the above dictionary productions will fire before this
;;;   change of state production
;;; *******************************************************************************

(defrule done_labeling
	(declare (salience -10))
	?f1 <- (stage (value labeling))
	=>
	(modify ?f1 (value plot_remaining_edges)))

;;; **************************************************
;;; plot_remaining: At this point, some labellings may
;;;   have not been plotted, so plot them
;;; **************************************************

(defrule plot_remaining
	(stage (value plot_remaining_edges))
	?f2 <- (edge (plotted nil) (label ?label&~nil) (p1 ?p1) (p2 ?p2))
	=>
	(modify ?f2 (plotted t)))

;;; ********************************************************************************
;;; plot_boundaries: If we have been un able to label an edge, assume that it is a
;;;   boundary. This is a total Kludge, but what the hell. (if we assume only
;;;   valid drawings will be given for labeling, this assumption generally is true!)
;;; ********************************************************************************

(defrule plot_boundaries
	(stage (value plot_remaining_edges))
	?f2 <- (edge (plotted nil) (label nil) (p1 ?p1) (p2 ?p2))
	=>
	(modify ?f2 (plotted t)))

;;; ****************************************************************************
;;; done_plotting: If there is no more work to do, then we are done and flag it.
;;; ****************************************************************************

(defrule done_plotting
	(declare (salience -10))
	?f1 <- (stage (value plot_remaining_edges))
	(not (edge (plotted nil)))
	=>
	(modify ?f1 (value done)))

error: pathspec 'clipsfiles/waltz/waltz_10minutes.clp' did not match any file(s) known to git