#+Title: Application of Rules to User Inputted Forms
#+AUTHOR: Sam Flint
#+EMAIL: swflint@flintfam.org
#+DATE: \today
#+INFOJS_OPT: view:info toc:nil path:http://flintfam.org/org-info.js
#+OPTIONS: toc:nil H:5 ':t *:t
#+PROPERTY: noweb no-export
#+PROPERTY: comments noweb
#+LATEX_HEADER: \parskip=5pt
#+LATEX_HEADER: \lstset{texcl=true,breaklines=true,columns=fullflexible,basicstyle=\ttfamily,frame=lines,literate={lambda}{$\lambda$}{1} {set}{$\gets$}1 {setq}{$\gets$}1 {setf}{$\gets$}1 {<=}{$\leq$}1 {>=}{$\geq$}1}
#+LATEX_HEADER: \usepackage[margins=1in]{geometry}

# #+BEGIN_abstract
# The use of rules to manipulate information is quite prevalent.  This shows itself in several mathematical concepts such as derivation, simplification and much of algebraic solving.  Because of this, and a desire to build something of a miniature Computer Algebra System, I've written a rule and application system.  This provides the logical structure to create rule types, and define rules using those rule types.
# #+END_abstract

#+TOC: headlines 3
#+TOC: listings

* Rule Management

** Types
:PROPERTIES:
:ID:       6c1e50a4-1e26-4df0-b808-4deb3b2964b7
:END:

#+Caption: Rule Types
#+Name: rule-types
#+BEGIN_SRC lisp
  (defmacro define-rule-type (type-name)
    (let ((rule-gen-name (symbolicate 'define- type-name '-rule))
          (apply-of-type-name (symbolicate 'apply-rules-of- type-name)))
      `(progn
         (pushnew ',type-name *rules-types*)
         (defmacro ,rule-gen-name (name (applicability-type &rest applicability-test) (&rest arguments) &body action)
           `(define-rule ,name ,(quote ,type-name) (,applicability-type ,@applicability-test) (,@arguments) ,@action))
         (defun ,apply-of-type-name (data)
           (let ((action (rule-action
                          (first (remove-if-not #'(lambda (rule)
                                                    (handler-bind ((sb-int:simple-program-error #'(lambda (&rest stuff) nil)))
                                                      (apply (rule-test rule) data))
                                                    )
                                                (get-rules-of-type ',type-name))))))
             (apply action data)))
         ',type-name)))
#+END_SRC

** Definition
:PROPERTIES:
:ID:       6abeb82b-2d32-4d11-be81-973486464a46
:END:

#+Caption: Rule Definition
#+Name: rule-definition
#+BEGIN_SRC lisp
  (defmacro define-rule (name type (applicability-type &rest applicability-test-arguments) (&rest arguments) &body action)
    (let ((applicability-test (generate-applicability-test applicability-type applicability-test-arguments name))
          (applicability-test-name (symbolicate name '-applyable-p))
          (action-name (symbolicate 'apply- name '-action)))
      `(progn
         ,applicability-test
         (defun ,action-name (,@arguments)
           ,@action)
         (push (make-instance '<rule>
                              :name ',name
                              :type ',type
                              :test #',applicability-test-name
                              :action #',action-name)
               ,*rules*)
         ',name)))
#+END_SRC

** Retrieval
:PROPERTIES:
:ID:       398313b0-9b42-4d63-abd2-672309e4ffda
:END:

#+Caption: Rule Retrieval
#+Name: rule-retrieval
#+BEGIN_SRC lisp
  (defun get-rules-of-type (type)
    (remove-if-not #'(lambda (rule)
                       (equal type
                              (rule-type rule)))
                   ,*rules*))
#+END_SRC

** Applicability Tests
:PROPERTIES:
:ID:       c5bb891b-c9eb-40b9-8c2a-24945bdf9d9b
:END:

#+Caption: Applicability Tests
#+Name: applicability-tests
#+BEGIN_SRC lisp
  <<type-testing>>
  <<arity-testing>>
  <<arg-parsing-arity-testing>>
  <<length-testing>>
  <<complex-testing>>
  <<arg-parsing-complex-testing>>

  (defun generate-applicability-test (type type-arguments name)
    (check-type type keyword)
    (check-type type-arguments cons)
    (check-type name symbol)
    (let ((test-name (symbolicate name '-applyable-p)))
      (ecase type
        (:type
         (make-type-test test-name type-arguments))
        (:arity
         (make-arity-test test-name type-arguments))
        (:complex-arity
         (make-complex-arity test-name type-arguments))
        (:length
         (make-length-test test-name type-arguments))
        (:complex
         (make-complex-test test-name type-arguments))
        (:complex-arg-parsing
         (make-complex-arg-parsing-test test-name type-arguments)))))
#+END_SRC

*** Type Testing
:PROPERTIES:
:CREATED:  <2015-10-31 Sat 00:11>
:END:

#+Caption: Type Testing
#+Name: type-testing
#+BEGIN_SRC lisp
  (defun make-type-test (name arguments)
    (destructuring-bind (type-expression) arguments
      `(defun ,name (data)
         (typep data ',type-expression))))
#+END_SRC

*** Arity Testing
:PROPERTIES:
:CREATED:  <2015-10-31 Sat 00:11>
:END:

#+Caption: Arity Testing
#+Name: arity-testing
#+BEGIN_SRC lisp
  (defun make-arity-test (name arguments)
    (destructuring-bind (function-name arity &optional (arity-type '=)) arguments
      (check-type arity-type (member = > >=))
      `(defun ,name (function &rest arguments &aux (arg-count (length arguments)))
         (and (eq function ',function-name)
            (,arity-type arg-count ,arity)))))
#+END_SRC

*** Argument Parsing Arity Testing
:PROPERTIES:
:CREATED:  <2015-10-31 Sat 00:11>
:END:

#+Caption: Argument Parsing Arity Testing
#+Name: arg-parsing-arity-testing
#+BEGIN_SRC lisp
  (defun make-complex-arity (name arguments)
    (destructuring-bind (function-name arity (&rest arguments) &body body) arguments
      `(defun ,name (function &rest arguments &aux (arg-count (length arguments)))
         (and (eq function ',function-name)
            (= arg-count ,arity)
            (destructuring-bind (,@arguments) arguments
              ,@body)))))
#+END_SRC

*** Length Testing
:PROPERTIES:
:CREATED:  <2015-10-31 Sat 00:11>
:END:

#+Caption: Length Testing
#+Name: length-testing
#+BEGIN_SRC lisp
  (defun make-length-test (name arguments)
    (destructuring-bind (length &optional (test '=)) arguments
      `(defun ,name (&rest data)
         (,test (length data) ,length))))
#+END_SRC

*** Complex Testing
:PROPERTIES:
:CREATED:  <2015-10-31 Sat 00:12>
:END:

#+Caption: Complex Testing
#+Name: complex-testing
#+BEGIN_SRC lisp
  (defun make-complex-test (name arguments)
    (destructuring-bind (&body test-body) arguments
      `(defun ,name (datum)
         ,@test-body)))
#+END_SRC

*** Argument Parsing Complex Testing
:PROPERTIES:
:CREATED:  <2015-10-31 Sat 00:12>
:END:

#+Caption: Argument Parsing Complex Testing
#+Name: arg-parsing-complex-testing
#+BEGIN_SRC lisp
  (defun make-complex-arg-parsing-test (name arguments)
    (destructuring-bind ((&rest arguments) &body body) arguments
      `(defun ,name (,@arguments)
         ,@body)))
#+END_SRC

** Storage
:PROPERTIES:
:ID:       8bf71f6e-bd84-4ca6-aacc-1baceff60752
:END:

#+Caption: Rule Storage
#+Name: rule-storage
#+BEGIN_SRC lisp
  (defclass <rule> ()
    ((name :initarg :name
           :accessor rule-name
           :type symbol)
     (type :initarg :type
           :accessor rule-type
           :type symbol)
     (applicability-test :initarg :test
                         :accessor rule-test
                         :type function)
     (action :initarg :action
             :accessor rule-action
             :type function)))

  (defvar *rules* nil)

  (defvar *rules-types* nil)
#+END_SRC

* Miscellaneous Functions
:PROPERTIES:
:CREATED:  <2015-10-31 Sat 12:06>
:END:

* Packaging
:PROPERTIES:
:ID:       0ace86ca-af91-45ff-a945-0ab345a29047
:END:

#+Caption: Packaging
#+Name: packaging
#+BEGIN_SRC lisp :tangle "rules.lisp"
  ;;;; rules.lisp
  ;;;;
  ;;;; Copyright (c) 2015 Samuel W. Flint <swflint@flintfam.org>

  (defpackage #:rules
    (:use #:cl)
    (:import-from #:alexandria
                  #:symbolicate)
    (:export #:define-rule-type
             #:define-rule))

  (in-package #:rules)

  ;;; "rules" goes here.

  <<rule-storage>>

  <<applicability-tests>>

  <<rule-definition>>

  <<rule-retrieval>>

  <<rule-types>>

  ;;; End rules
#+END_SRC