git.fiddlerwoaroof.com
decision-table.lisp
a8cd04b5
 (defpackage :fwoar.decision-table
   (:use :cl )
   (:export ))
 (in-package :fwoar.decision-table)
 
 (defun array= (array1 array2 &optional (element-compare 'eql))
   (and (= (length array1)
           (length array2))
        (every element-compare array1 array2)))
 
 (defun apply-decision-table (table inputs)
   (destructuring-bind (row col) (array-dimensions table)
     (loop with input-length = (length inputs)
           for cur-row from 0 below row
           for array-accessor = (make-array input-length
                                            :displaced-to table
                                            :displaced-index-offset (array-row-major-index table cur-row 0))
             then (adjust-array array-accessor input-length
                                :displaced-to table
                                :displaced-index-offset (array-row-major-index table cur-row 0))
           while (not (array= inputs array-accessor))
           finally (return
                     (aref table cur-row (1- col))))))
 
 (defmacro let-order ((min max) (a b) &body body)
   (alexandria:once-only (a b)
     `(destructuring-bind (,min ,max) (if (<= (length ,a) (length ,b))
                                          (list ,a ,b)
                                          (list ,b ,a))
        ,@body)))
 
 (defmacro let-by-length ((a b) &body body)
   `(let-order (,a ,b) (,a ,b)
      ,@body))
 
 ;; 
 ;;
 ;;
 ;;
 
 (defun levehnstein-1-p (a b)
   (let-by-length (a b)
     (if (equal a b)
         t
         (cond ((= (length b)
                   (length a))
                (= (loop
                     for x from 0 below (length a)
                     when (not (eql (elt a x)
                                    (elt b x)))
                       count 1)
                   1))
               ((= (- (length b)
                      (length a))
                   1)
                (some 'identity
                      (map 'list
                           (op (equal a
                                      (remove _1 b
                                              :start _2
                                              :count 1)))
                           b (alexandria:iota (length b)))))))))