elasticity.lisp

   1 ;;; Author: Robert Strandh
   2 ;;; Copyright (c) 2005 by Robert Strandh (strandh@labri.fr)
   3
   4 ;;; This library is free software; you can redistribute it and/or
   5 ;;; modify it under the terms of the GNU Library General Public
   6 ;;; License as published by the Free Software Foundation; either
   7 ;;; version 2 of the License, or (at your option) any later version.
   8 ;;;
   9 ;;; This library is distributed in the hope that it will be useful,
  10 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12 ;;; Library General Public License for more details.
  13 ;;;
  14 ;;; You should have received a copy of the GNU Library General Public
  15 ;;; License along with this library; if not, write to the
  16 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  17 ;;; Boston, MA  02111-1307  USA.
  18
  19 ;;; An elasticity function determines the physical size of a sequence
  20 ;;; of objects as a function of the force that is applied to it.  In
  21 ;;; our case, the force is always greater than or equal to zero, and
  22 ;;; in the direction of stretching the objects.  For large force
  23 ;;; values, the size of the sequence is always the force value times
  24 ;;; the sum of the individual elasticities of each object in the
  25 ;;; sequence.  However, individual objects may have stoppers that
  26 ;;; require them to be larger or equal to a particular value.  For an
  27 ;;; object to acquire a size larger than its stopper value, the force
  28 ;;; must therefor be larger than the stopper value divide by the
  29 ;;; elasticity.
  30
  31 ;;; For a sequence of such objects, we thus get an elasticity function
  32 ;;; that is convex and piecewise linear, constant for small values of
  33 ;;; the force, and then a piecewise increasing slope for increasing
  34 ;;; values of the force.
  35
  36 ;;; We represent such a function by a number and a list.  The number
  37 ;;; is the constant value for small values of the force.  The elements
  38 ;;; of the list (which might be empty) are pairs of the form (x . s)
  39 ;;; where x is the value of the force at which the slope changes, and
  40 ;;; s is the slope after than point.
  41
  42 (in-package :gsharp-drawing)
  43
  44 (defgeneric add-elasticities (e1 e2)
  45   (:documentation "add two elasticity functions"))
  46
  47 (defgeneric zero-force-size (elasticity)
  48   (:documentation "return the size of an elasticity at zero force"))
  49
  50 (defgeneric force-at-size (elasticity size)
  51   (:documentation "for a given size, return the force that is
  52 required to obtain that size.  The size must be larger than the
  53 size at zero force, as reported by zero-force-size"))
  54
  55 (defgeneric size-at-force (elasticity force)
  56   (:documentation "for a given force, return the size at that force"))
  57
  58 (defclass elasticity ()
  59   ((zero-force-size :initarg :zero-force-size :reader zero-force-size)
  60    (elements :initform '() :initarg :elements :reader elements)))
  61
  62 (defmethod print-object ((e elasticity) stream)
  63   (print-unreadable-object (e stream :type t :identity t)
  64     (format stream "zero-size: ~a  elements:~s"
  65             (zero-force-size e) (elements e))))
  66
  67 (defun make-zero-elasticity (size)
  68   "create an elasticity function that is constant for all
  69 values of the force"
  70   (make-instance 'elasticity :zero-force-size size))
  71
  72 (defun make-elementary-elasticity (zero-force-size slope)
  73   "create an elasticity function that gives a size which is the
  74 product of the force and slope given, except that it will never
  75 have a size smaller than the zero-force-size given"
  76   (make-instance 'elasticity
  77     :zero-force-size zero-force-size
  78     :elements `((,(/ zero-force-size slope) . ,slope))))
  79
  80 (defmethod add-elasticities ((e1 elasticity) (e2 elasticity))
  81   (let ((l1 (elements e1))
  82         (l2 (elements e2))
  83         (s1 0)
  84         (s2 0)
  85         (zero-force-size (+ (zero-force-size e1) (zero-force-size e2)))
  86         (elements '()))
  87     (loop until (and (null l1) (null l2))
  88           do (cond ((null l1)
  89                     (setf s2 (cdar l2))
  90                     (push (cons (caar l2) (+ s1 s2)) elements)
  91                     (pop l2))
  92                    ((null l2)
  93                     (setf s1 (cdar l1))
  94                     (push (cons (caar l1) (+ s1 s2)) elements)
  95                     (pop l1))
  96                    ((< 0.99999 (/ (+ (caar l1) 0.00001) (+ (caar l2) .00001)) 1.00001)
  97                     (setf s1 (cdar l1)
  98                           s2 (cdar l2))
  99                     (push (cons (/ (+ (caar l1) (caar l2)) 2) (+ s1 s2)) elements)
 100                     (pop l1)
 101                     (pop l2))
 102                    ((< (caar l1) (caar l2))
 103                     (setf s1 (cdar l1))
 104                     (push (cons (caar l1) (+ s1 s2)) elements)
 105                     (pop l1))
 106                    (t
 107                     (setf s2 (cdar l2))
 108                     (push (cons (caar l2) (+ s1 s2)) elements)
 109                     (pop l2))))
 110     (make-instance 'elasticity
 111       :zero-force-size zero-force-size
 112       :elements (nreverse elements))))
 113
 114 (defmethod force-at-size ((e elasticity) size)
 115   (let ((l (elements e))
 116         (current-size (zero-force-size e)))
 117     (assert (not (null l)))
 118     (assert (>= size current-size))
 119     (let ((current-force 0)
 120           (current-slope 0))
 121       (loop until (or (null l)
 122                       (>= (+ current-size (* current-slope (- (caar l) current-force)))
 123                           size))
 124             do (incf current-size (* current-slope (- (caar l) current-force)))
 125             do (setf current-force (caar l)
 126                      current-slope (cdar l))
 127             do (pop l))
 128       (+ current-force (/ (- size current-size) current-slope)))))
 129
 130 (defmethod size-at-force ((e elasticity) force)
 131   (let ((l (elements e))
 132         (current-size (zero-force-size e)))
 133     (let ((current-force 0)
 134           (current-slope 0))
 135       (loop until (or (null l)
 136                       (>= (caar l) force))
 137             do (incf current-size (* current-slope (- (caar l) current-force)))
 138             do (setf current-force (caar l)
 139                      current-slope (cdar l))
 140             do (pop l))
 141       (+ current-size (* (- force current-force) current-slope)))))