IT214 sample brute force optimal thing finder

packaroo.cl

;; vim: set sts=2 sw=2 et sm lisp :

(declaim (optimize (debug 3)
                   (speed 3)
                   (compilation-speed 0)
                   (safety 3)
                   (space 0)))

(defun range0x (n)
  (do ((i   (1- n) (1- i))
       (acc (list) (cons i acc)))
    ((< i 0) acc)))

(defun range1i (n)
  (do ((i   n      (1- i))
       (acc (list) (cons i acc)))
    ((< i 1) acc)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defvar *width-specific-environ*
  (list '($maxwidth 9 17)
        '($loswitchcost 3 4)
        ))

(defun environ-for-width (node is16)
  (etypecase node
    (cons
     (mapcar
       (lambda (n)
         (environ-for-width n is16))
       node))
    (symbol
     (let* ((tuple (assoc node *width-specific-environ*)))
       (if tuple
         (if is16 (third tuple) (second tuple))
         node)))
    (t node)))

(defmacro defun-per-width (name args &body body)
  (let* ((name-8  (intern
                    (format nil "~a-8"
                            (symbol-name name))))
         (name-16 (intern
                    (format nil "~a-16"
                            (symbol-name name)))))
    `(progn
       (push '(,name ,name-8 ,name-16)
             *width-specific-environ*)
       (defun ,name-8 ,(environ-for-width args nil)
         ,@(environ-for-width body nil))
       (defun ,name-16 ,(environ-for-width args t)
         ,@(environ-for-width body t))
       )))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun-per-width cost-to-next (old new)
  (declare (type (integer 1 $maxwidth) old new))
  (cond ((=  old new) new)
        ((<= old 6)   (+ old new $loswitchcost))
        (t            (+ old new))))

(defun-per-width width-list-cost (widths &optional (from $maxwidth))
  (declare (type fixnum from))

  (let* ((acc 0)
         (old from))
    (declare (type fixnum acc old))

    (dolist (new widths)
      (declare (type fixnum new))

      (incf acc (cost-to-next old new))
      (setf old new))

    acc))

(defun-per-width find-best-widths (widths &optional (from $maxwidth))
  ;; BRUTE FORCE ALGORITHM
  (let* ((best-output widths)
         (best-score  (width-list-cost widths from))
         (new-output  (copy-list widths))
         (new-score   0)
         (done-flag   nil))
    (declare (type fixnum best-score new-score))

    (labels ((advance-to-next-width (src cmp)
               (cond
                 ((null src)
                  ;; TODO: actually learn how to use throw/catch properly
                  (setf done-flag t)
                  nil)
                 ((>= (car src) (min $maxwidth 10))
                  (cons (car cmp)
                        (advance-to-next-width
                          (cdr src)
                          (cdr cmp))))
                 (t (cons (1+ (car src))
                          (cdr src))))))
      (block main-loop
        (do () (nil)
          ;; Attempt to bump the widths in order
          (setf new-output
                (advance-to-next-width
                  new-output widths))
          (when done-flag
            (return-from main-loop nil))
          (setf new-score
                (width-list-cost new-output from))
          (when (<= new-score best-score)
            (print `(,new-score ,new-output))
            (setf best-score  new-score)
            (setf best-output (copy-list new-output))))))

    `(,best-score ,best-output)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun print-transfer-table (size func)
  (format t "~3a |" "")
  (dolist (x (range1i size))
    (format t "~3d" x))
  (format t "~%")
  (format t "----+")
  (dolist (x (range1i size))
    (format t "---"))
  (format t "~%")

  (dolist (y (range1i size))
    (format t "~3d |" y)
    (dolist (x (range1i size))
      (format t "~3d" (funcall func y x)))
    (format t "~%"))
  (terpri))

(print-transfer-table 9  #'cost-to-next-8)
(print-transfer-table 17 #'cost-to-next-16)

(let* ((base-list '(1 2 3 4 5 6 7 8 9)))
  (print (find-best-widths-8  base-list))
  (terpri)
  (print (find-best-widths-16 base-list))
  (terpri))