newlispfanclub.alh.net

Code: Select all

> (load "mixed-radix.lsp")
MAIN
> (mixed-radix:new HHMMSS (hours minutes seconds) (1 60 60))
HHMMSS
> (HHMMSS:to-minutes '(3 34 42))
214.7
> (HHMMSS:to-seconds '(3 34 42))
12882
> (HHMMSS:from-minutes 214.7)
(3 34 42)
> (HHMMSS:from-seconds 12882)
(3 34 42)
> (HHMMSS:+ '(3 34 42) '(1 54 59))
(5 29 41)

Code: Select all

;;--------------------------------------
;; Application: Floor plan lengths

(load "mixed-radix.lsp")

(mixed-radix:new ftin (feet inches) (1 12))

(define rawdims '((laundry ((5 5) (2 11) (4 6.5))
                           ((7 1.5)))
                  (bath ((4 10.5))
                        ((7 1)))
                  (family-room ((10 4.5) (8 11.5) (0 1))
                               ((12 1) (10 0) (0 1)))))

(define (dim<-rawdim rawdim)
  (list (rawdim 0)
        (apply ftin:add (rawdim 1))
        (apply ftin:add (rawdim 2))))

(define dims (map dim<-rawdim rawdims))

(define (sqft<-dim dim)
  (list (dim 0)
        (mul (ftin:to-feet (dim 1))
             (ftin:to-feet (dim 2)))))

;; Show and tell.
(println "Dimensions:")
(println dims)
(define sqftages (map sqft<-dim dims))
(println "SQ FTages:")
(println sqftages)
(println "Total SQ FT = " (apply add (map last sqftages)))

Code: Select all

Dimensions:
((laundry (12 10.5) (7 1.5)) (bath (4 10.5) (7 1)) (family-room (
   19 5) 
  (22 2)))
SQ FTages:
((laundry 91.734375) (bath 34.53125) (family-room 430.4027778))
Total SQ FT = 556.6684028

Code: Select all

;;;; mixed-radix.lsp -- Mixed radix numbers for newLISP
;;;; Author: Rick Hanson
;;;; Date: 9 June 2007

(context 'mixed-radix)

;;;-------------------------------------
;;; Slots and Constructor

(define labels '())
(define bases '())

(define-macro (mixed-radix:new mrn-symbol mrn-labels mrn-bases)
  (letex (mrn-labels mrn-labels mrn-bases mrn-bases)
    (MAIN:new 'mixed-radix mrn-symbol)
    (let (ctx (eval mrn-symbol)
          unqualify (lambda (symb) (replace ".*:" (string symb) "" 0)))
      (setq ctx:labels (quote mrn-labels))
      (setq ctx:bases (quote mrn-bases))

      ;; Setup the conversion functions for new instances.
      (dolist (label ctx:labels)
        (set (sym (append "to-" (unqualify label)) ctx)
             (letex ($$idx $idx fsym (sym 'mid-units<-mixrad ctx))
               (curry fsym $$idx)))
        (set (sym (append "from-" (unqualify label)) ctx)
             (letex ($$idx $idx fsym (sym 'mixrad<-mid-units ctx))
               (curry fsym $$idx))))
      mrn-symbol)))

;;;-------------------------------------
;;; Utilities used in this context.

(define (compose)
  (apply (lambda (f g) (expand (lambda () (f (apply g (args)))) 'f 'g))
         (args) 2))

(define-macro (kurry f)
  (letex ($f (eval f)
          $cargs (map eval (args)))
    (lambda () (apply $f (append (quote $cargs) (args))))))

(define (butlast xs) (0 (- (length xs) 1) xs))

;; This version of `unfold' uses `while' and `setq' (for reasons of
;; time and space efficiency) -- "don't pay any attention to the man
;; behind the curtain!" :-)
(define (unfold p f g s post)
  (let (acc '())
    (while (not (p s))
      (push (f s) acc -1)
      (setq s (g s)))
    (post p f g s acc)))

;;;-------------------------------------
;;; Method Definitions

(define (low-units<-mixrad M (bases bases))
  "Convert a mixrad `M' to a scalar in low-order units with respect
to the list of bases `bases'."
  (rotate bases -1)
  (apply MAIN:add
    (map (lambda (i) (mul (M i) (apply mul (i bases))))
         (sequence 0 (- (length M) 1)))))

(define (high-units<-mixrad M (bases bases))
  "Convert a mixrad `M' to a scalar in high-order units with
respect to the list of bases `bases'."
  (div (low-units<-mixrad M) (apply mul bases)))

(define (mid-units<-mixrad mid M)
  "Convert a mixrad `M' to a scalar in `mid'-order units with
respect to the list of bases `bases'.  `mid' is zero-based.  This
function acts as if the radix point of `M' were after the
`mid'-th digit (from the left).  For instance to convert 3 hours,
34 minutes, 42 seconds into minutes, say
    (mixed-radix:new HHMMSS (hours minutes seconds) (1 60 60))
    (HHMMSS:mid-units<-mixrad 1 '(3 34 42))
which yields 214.7, as expected."
  (letn (mid+1 (+ mid 1)
         basesL (0 mid+1 bases)
         digitsL (0 mid+1 M)
         basesR (cons 1 (mid+1 bases))
         digitsR (cons 0 (mid+1 M)))
    (MAIN:add (low-units<-mixrad digitsL basesL)
              (high-units<-mixrad digitsR basesR))))

(define (mixrad<-low-units N (bases bases))
  "Convert `N', which is a scalar in low-order units, to a mixrad,
with respect to the list of bases 'bases'."
  (rotate bases -1)
  (unfold (lambda (s) (>= (s 1) (length bases)))
          (lambda (s) (/ (s 0) (apply mul ((s 1) bases))))
          (lambda (s) (list (mod (s 0) (apply mul ((s 1) bases))) (+ (s 1) 1)))
          ;; In the seed, keep track of the latest remainder AND an
          ;; incrementing index with which we use to slice `bases':
          (list N 0)
          ;; In the post-processor, add the last remainder into the
          ;; last entry in the accumulated list:
          (lambda (p f g s res0)
            (append (butlast res0) (list (MAIN:add (s 0) (last res0)))))))

;; This is not used by any method or instance conversion function, but
;; is here for completion sake.
(define (mixrad<-high-units N (bases bases))
  "Convert `N', which is a scalar in high-order units, to a mixrad,
with respect to the list of bases 'bases'."
  (mixrad<-low-units (apply mul (cons N bases))))

(define (mixrad<-mid-units mid N)
  "Convert `N', which is a scalar in mid-order units, to a mixrad,
with respect to the list of bases 'bases'."
  (mixrad<-low-units (apply mul (cons N ((+ mid 1) bases)))))

;; Now it's easy to define a normalization function.
(define (normalize M)
  "Return the canonical representation of mixrad `M' with respect to
the list of bases `bases'."
  (mixrad<-low-units (low-units<-mixrad M)))

(define (component-wise-operator op) (compose normalize (kurry map op)))
(define mixed-radix:add (component-wise-operator MAIN:add))
(define mixed-radix:sub (component-wise-operator MAIN:sub))
(define mixed-radix:+ mixed-radix:add)
(define mixed-radix:- mixed-radix:sub)

(context MAIN)

Code: Select all

(define-mixed-radix hhmmss ...)

Code: Select all

(set 'ctx (eval ctx)) ; get context out of symbol

Code: Select all

(define mixed-radix:mul (component-wise-operator MAIN:mul))
(define mixed-radix:div (component-wise-operator MAIN:div))