LARCS/rules-application.org

Application of Rules to User Inputted Forms

Rule Management

Types

  (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)))

Definition

  (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)))

Retrieval

  (defun get-rules-of-type (type)
    (remove-if-not #'(lambda (rule)
                       (equal type
                              (rule-type rule)))
                   ,*rules*))

Applicability Tests

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

Type Testing

  (defun make-type-test (name arguments)
    (destructuring-bind (type-expression) arguments
      `(defun ,name (data)
         (typep data ',type-expression))))

Arity Testing

  (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)))))

Argument Parsing Arity Testing

  (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)))))

Length Testing

  (defun make-length-test (name arguments)
    (destructuring-bind (length &optional (test '=)) arguments
      `(defun ,name (&rest data)
         (,test (length data) ,length))))

Complex Testing

  (defun make-complex-test (name arguments)
    (destructuring-bind (&body test-body) arguments
      `(defun ,name (datum)
         ,@test-body)))

Argument Parsing Complex Testing

  (defun make-complex-arg-parsing-test (name arguments)
    (destructuring-bind ((&rest arguments) &body body) arguments
      `(defun ,name (,@arguments)
         ,@body)))

Storage

  (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)

Miscellaneous Functions

Packaging

  ;;;; 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