2. Numbers

;;;-----------------------------
(if (every #'digit-char-p string)
    (progn
      ;; is a number
      )
    (progn
      ;; is not
      ))
;;;-----------------------------
;;; Strings and numbers are separate data types in CL. These tests
;;; check whether a string represents a number
(unless (every #'digit-char-p string)
  (format *error-output* "string has nondigits"))
(unless (scan "^\\d+$" string) ; rejects -3
  (format *error-output* "not a natural number"))
(unless (scan "^-?\\d+$" string) ; rejects +3
  (format *error-output* "not an integer"))
(unless (scan "^[+-]?\\d+$" string)
  (format *error-output* "not an integer"))
(unless (scan "^-?(?:\\d+(?:\\.\\d*)?|\\.\\d+)$" string)
  (format *error-output* "not an integer"))
(unless (scan "^([+-]?)(?=\\d|\\.\\d)\\d*(\\.\\d*)?([Ee]([+-]?\\d+))?$"
                       string)
  (format *error-output* "not a C float"))
;;;-----------------------------
(defun getnum (string)
  "This function is not safe to call on untrusted input."
  (with-input-from-string 
      (is (regex-replace #?"\s+$" 
                                  (regex-replace #?"^\s+" string "") ""))
    (let ((num (read is nil nil nil)))
      (and
       ;; Make sure there's no junk following the number
       (eql (read-char is nil :eof nil) :eof)
       (numberp num)
       num))))

(defun is-numeric (string)
  (not (null (getnum string))))
;;;-----------------------------

;;;-----------------------------
(defun equal-to-accuracy (number1 number2 dp)
  "Return non-nil if NUMBER1 and NUMBER2 are equal to DP number of
decimal places."
  (let* ((difference (abs (- number1 number2)))
         (delta (expt 10 (- dp))))
    (< difference delta)))
;;;-----------------------------
(let* ((wage 536)                       ; $5.36/hour
       (week (* 40 wage)))              ; $214.40
  (format t "One week's wage is: $~,2F~%" (/ week 100)))
;;One week's wage is: $214.40
;;;-----------------------------

;;;-----------------------------
(setf rounded (format nil "~FORMATF" unrounded))
;;;-----------------------------
(let* ((a 0.255)
       (b (/ (fround a 0.01) 100)))
  (format t "Unrounded: ~F~%Rounded: ~,2F~%" a b))
;;Unrounded: 0.255
;;Rounded: 0.26
;;;-----------------------------
(progn
  (format t "~&number~Tint~Tfloor~Tceil~%")
  (let ((as '(3.3 3.5 3.7 -3.3)))
    (dolist (a as)
      (format t "~@{~4,1F~^~T~}~%"
              a
              (ftruncate a)
              (ffloor a)
              (fceiling a)))))
;;number int floor ceil
;; 3.3  3.0  3.0  4.0
;; 3.5  3.0  3.0  4.0
;; 3.7  3.0  3.0  4.0
;;-3.3 -3.0 -4.0 -3.0
;;;-----------------------------

;;;-----------------------------
(defun dec2bin (dec)
  (format nil "~2R" dec))
;;;-----------------------------
(defun bin2dec (bin)
  "BIN is a string containing only #\1 and #\0 characters.  Returns
its integer equivalent."
  (read (make-string-input-stream (concatenate 'string "#b" bin)) 
        t nil nil))
;;;-----------------------------
(setf num (bin2dec "0110110"))          ; $num is 54
(setf binstr (dec2bin 54))              ; binstr is "110110"
;;;-----------------------------

;;; @PLEAC@@_2.5
(defun seq (start end)
  (loop for i from start to end collect i))

(format t "Infancy is: ~{~A~^ ~}~%" (seq 0 2))
(format t "Toddling is: ~{~A~^ ~}~%" (seq 3 4))
(format t "Childhood is: ~{~A~^ ~}~%" (seq 5 12))
; => Infancy is: 0 1 2
;    Toddling is: 3 4
;    Childhood is: 5 6 7 8 9 10 11 12

;;; CL has a built in FORMAT directive (used below) to print out
;;; numbers as roman numerals, but doesn't have a built-in mechanism
;;; to convert back.  Here are some rough CL equivalents of Perl's
;;; Roman package.

(defun romanchar->num (x) 
  (case (char-downcase x)
    (#\m 1000)
    (#\d 500)
    (#\c 100)
    (#\l 50)
    (#\x 10)
    (#\v 5)
    (#\i 1)
    (t 0)))

(defun isroman (string)
  (every #'(lambda (c)
             (plusp (romanchar->num c)))
         string))

(defun arabic (string)
  (let ((digits (map 'list #'romanchar->num string)))
    (reduce #'+ (mapcar #'(lambda (digit next-digit)
                            (if (< digit next-digit) 
                                (- digit) 
                                digit))
                        digits
                        (append (rest digits) '(0))))))

(setf roman (format nil "~@R" arabic))  ; convert to roman numerals
(when (isroman roman) (setf arabic (arabic roman))) ; convert from roman numerals 
;;;-----------------------------
(setf roman-fifteen (format nil "~@R" 15))
(format t "Roman for fifteen is ~A~%" roman-fifteen)
(setf arabic-fifteen (arabic roman-fifteen))
(format t "Converted back, ~A is ~A~%" roman-fifteen arabic-fifteen)
;;Roman for fifteen is XV
;;Converted back, XV is 15
;;;-----------------------------

;;;-----------------------------
(setf random (+ (random (+ y (- x) 1)) x)
;;;-----------------------------
(setf random (+ (random 51) 25))
(format t "~A~%" random)
;; If you wanted to use floats...
(+ (random 51.0) 25.0)
;;;-----------------------------
(setf elt (aref array (random (length array))))
;;;-----------------------------
(setf chars "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz012345789!@$%^&*")
(setf password (coerce (loop repeat 8 collect (aref chars (random (length chars)))) 'string))
;;;-----------------------------

;;;-----------------------------
;; CL intentionally does not have an equivalent of Perl's srand(); you
;; can call MAKE-RANDOM-STATE but its inner workings are not exposed.
(setf *random-state* (make-random-state t))
;;;-----------------------------

;;;-----------------------------
;; In CL, RANDOM is supposed to return a truly random,
;; uniformly-distributed value.
(setf random (random))
;;;-----------------------------

;;;-----------------------------
;; Note: (random 1.0) is the same as calling Perl's rand() with no
;; arguments.
(defun gaussian-rand ()
  (do* ((u1 (1- (* 2 (random 1.0)))
            (1- (* 2 (random 1.0))))
        (u2 (1- (* 2 (random 1.0)))
            (1- (* 2 (random 1.0))))
        (w (+ (* u1 u1) (* u2 u2))
           (+ (* u1 u1) (* u2 u2))))
       ((< w 1.0)
        (let* ((w2 (sqrt (/ (* -2 (log w)) w)))
               (g2 (* u1 w2))
               (g1 (* u2 w2)))
          ;; No need for wantarray in CL because functions can return
          ;; multiple values.
          (values g1 g2)))))
;;;-----------------------------
(defun weight-to-dist (weights)
  "Takes a hash mapping key to weight and returns a hash mapping key
to probability.  WEIGHTS is an alist."
  (let ((dist (make-hash-table))
        (total (loop for (key . ignored-value) in weights sum key)))
    (loop for (key . weight) in weights
         do (setf (gethash key dist) (/ weight total)))
    dist))

(defun weighted-rand (dist)
  "Takes a hash mapping key to probability, and returns the
corresponding element."
  (loop
     for rand = (random 1.0)
     do
     (loop for key being the hash-keys of dist using (hash-value weight)
        do
        (decf rand weight)
        (when (minusp rand)
          (return-from weighted-rand key)))))
;;;-----------------------------
;; gaussian_rand as above
(let* ((mean 25)
       (sdev 2)
       (salary (+ (* (gaussian-rand) sdev) mean)))
  (format t "You have been hired at $~,2F~%" salary))
;;;-----------------------------

;;;-----------------------------
(defun deg2rad (degrees) 
  (* (/ degrees 180) pi))

(defun rad2deg (radians) 
  (* (/ radians pi) 180))
;;;-----------------------------
(setf radians (deg2rad degrees))
(setf degrees (rad2deg radians))
;;;-----------------------------
;; deg2rad and rad2deg defined either as above
(defun degree-sine (degrees)
  (let ((radians (deg2rad degrees)))
    (sin radians)))
;;;-----------------------------

;;;-----------------------------
;; tangent is built in to CL
(tan theta)
;;;-----------------------------
(setf y (acos 3.7))
;;;-----------------------------
(setf y (tan (/ pi 2)))
;;;-----------------------------

;;;-----------------------------
(setf log-e (log value))
;;;-----------------------------
(setf log-10 (log value 10))
(setf log-base-whatever (log value base))
;;;-----------------------------
;; In CL, don't need custom log_base function as LOG already does it
;;;-----------------------------
(setf answer (log 10000 10))
(format t "log10(10,000) = ~D~%" answer)
;; log10(10,000) = 4.0
;;;-----------------------------
(format t "log2(1024) = ~A~%" (log 1024 2))
;; log2(1024) = 10.0
;;;-----------------------------

;;;-----------------------------
;;;-----------------------------
(defun mmult (m1 m2)
  (check-type m1 (array * (* *)))
  (check-type m2 (array * (* *)))
  (let* ((m1-rows (array-dimension m1 0))
         (m1-columns (array-dimension m1 1))
         (m2-rows (array-dimension m2 0))
         (m2-columns (array-dimension m2 1)))
    (unless (= m1-columns m2-rows)
      (error 'simple-type-error
             :format-control "IndexError: matrices don't match: ~A != ~A"
             :format-args (list m1-columns m2-rows)))
    (let ((result (make-array (list m1-rows m2-columns))))
      (dotimes (i m1-rows)
        (dotimes (j m2-columns)
          (setf (aref result i j)
                (loop for k from 0 below m1-columns
                      summing (* (aref m1 i k) (aref m2 k j))))))
      result)))

(defun range (n)
  (loop for i from 0 below n collect i))

;; This isn't really necessary in CL, but is here to match the Perl
;; function.
(defun veclen (vector)
  (check-type vector simple-vector)
  (array-dimension vector 0))

;; This isn't really necessary in CL, but is here to match the Perl
;; function.
(defun matdim (matrix)
  (values (array-dimension matrix 0)
          (array-dimension matrix 1)))
;;;-----------------------------
;; Can't find an obvious equivalent to PDL (yet)
;;;-----------------------------
(setf x #2a((3 2 3)
            (5 9 8))
      y #2a((4 7)
            (9 3)
            (8 1)))

(setf z (mmult x y))
;;;-----------------------------

;;;-----------------------------
;; Complex numbers are built in to CL so there is no need to compute
;; their product by hand.
;;;-----------------------------
;; c = a * b using built-in CL functionality
(setf c (* a b))
;;;-----------------------------
;; Again, no need to do complex number stuff by hand.
;;;-----------------------------
(setf a #c(3 5))
(setf b #c(2 -2))
(setf c (* a b))
(format t "c = ~D+~Di~%" (realpart c) (imagpart c))
;; c = 16+4i
;;;-----------------------------
(setf c (* #c(3 5) #c(2 -2)))
(setf d #c(3 4))
(let ((sqrt-d (sqrt d)))
  (format t "sqrt(3+4i) = ~D+~Di~%" (realpart sqrt-d) (imagpart sqrt-d)))
;; sqrt(3+4i) = 2.0+1.0i
;;;-----------------------------

;;;-----------------------------
(defun hex (string)
  (parse-integer string 
                 :radix 16 
                 :start 2))             ; PARSE-INTEGER dislikes "0x"

(defun oct (string)
  (parse-integer string :radix 8))

(setf number (hex hexadecimal))
(setf number (oct octal))
;;;-----------------------------
(format t "Gimme a number in decimal, octal, or hex: ")
(setf num (read-line))
(when num
  (let ((num (chomp num)))
    (format t "~D ~:*~8R ~:*~X"
            (cond
              ((scan "^0x" num) (hex num))
              ((scan "^0" num) (oct num))
              (t (parse-integer num))))))
;;;-----------------------------
(format t "Enter file permission in octal: ")
(setf permissions (read-line))
(unless permissions (error "Exiting..."))
(let ((permissions (chomp permissions)))
  (format t "The decimal value is ~A~%" (oct permissions)))
;;;-----------------------------

(defun comma-separated (input &optional (n-digits 3))
  (coerce
   (first
    (reduce
     (lambda (char accum)
       (format *trace-output* "~S, ~S~%" accum char)
       (destructuring-bind (chars pos) accum
         (list
          (if (and (not (zerop pos)) (zerop (mod pos n-digits)))
              (cons char (cons #\, chars))
              (cons char chars))
          (1+ pos))))
     (coerce (format nil "~A" input) 'list)
     :initial-value (list nil 0)
     :from-end t))
   'string))

; (comma-separated 1234567890)   => "1,234,567,890"
; (comma-separated 1234567890 2) => "12,34,56,78,90"

;;; There isn't a  Lingua::EN::Inflect like F/OSS Common Lisp  library I know of
;;; (as of date 2009-03-09). Below is a quick & dirty implementation of its Perl
;;; equivalent.  On  the other hand, one  might be interested  in ~P (pluralize)
;;; directive of  the FORMAT  command and  its modifiers for  a quick  and cheap
;;; solution.

(setq *pluralization-regexps*
  '(("ss$"       . "sses")
    ("([psc]h)$" . "\\1es")
    ("z$"        . "zes")
    ("ff$"       . "ffs")
    ("f$"        . "ves")
    ("ey$"       . "eys")
    ("y$"        . "ies")
    ("ix$"       . "ices")
    ("([sx])$"   . "\\1es")
    ("$"         . "s")))

(defun pluralize (noun)
  (dolist (regexp *pluralization-regexps*)
    (multiple-value-bind (result foundp)
        (ppcre:regex-replace (car regexp) noun (cdr regexp))
      (when foundp (return result)))))

(format t "~{~{One ~A, two ~A.~}~%~}"
        (mapcar
         (lambda (noun) (list noun (pluralize noun)))
         '("fish" "fly" "ox" "species" "genus" "phylum" "cherub" "radius"
           "jockey" "index" "matrix" "mythos" "phenomenon" "formula")))
; => One fish, two fishes.
;    One fly, two flies.
;    One ox, two oxes.
;    One species, two specieses.
;    One genus, two genuses.
;    One phylum, two phylums.
;    One cherub, two cherubs.
;    One radius, two radiuses.
;    One jockey, two jockeys.
;    One index, two indexes.
;    One matrix, two matrices.
;    One mythos, two mythoses.
;    One phenomenon, two phenomenons.
;    One formula, two formulas.

(defun factorize (n)
  (let ((factors (make-hash-table))
        (m n))
    (loop for i from 2
          while (<= (1+ (* i 2)) m)
          do (loop while (zerop (mod m i))
                   do (setq m (/ m i))
                      (setf (gethash i factors)
                            (1+ (gethash i factors 0)))))
    (unless (or (= 1 m) (= n m))
      (setf (gethash m factors) 1))
    (format t "~A = ~{~{~A^~A~}~^ * ~}~%"
            n (loop for factor being each hash-key of factors
                     collect (list factor (gethash factor factors))))))

; (factorize 49249597168049276)
; => 49249597168049276 = 2^2 * 29^1 * 179^1 * 103387^1 * 22941707^1