11. References and Records

;;;-----------------------------
;; In CL you don't need extra syntax to treat variables (symbols) as
;; references, they already work that way.
(format t "~A" sref) ; prints the value that the reference SREF refers to
(setf sref 3)                           ; assigns SREF's referent
;;;-----------------------------
;; The Perl subsection here isn't any different from the above, in CL.
;;print ${$sref};             # prints the scalar $sref refers to
;;${$sref} = 3;               # assigns to $sref's referent
;;;-----------------------------
;; We're calling this MY-AREF instead of AREF to avoid confusion with
;; CL's built-in AREF function.
(setf my-aref array)       ; no special synatx needed to get reference
;;;-----------------------------
;; Not sure what the Perl here is trying to show.  Probably has no
;; realistic equivalent in CL.
;; $pi = \3.14159;
;; $$pi = 4;           # runtime error
;;;-----------------------------
(setf my-aref #(3 4 5)) ; new array (no "anonymous" distinction in CL)
;; MKHASH defined in appendix, not standard CL
(setf href (mkhash "How" "Now" "Brown" "Cow"))
;;;-----------------------------
(makunbound 'my-aref)
(setf my-aref #(1 2 3))
(format t "~A" my-aref)
;; #(1 2 3)
;;;-----------------------------
;; Perl doesn't support "rectangular" multi-dimensional arrays (i.e.,
;; a continuous block of memory with all cells preallocated), instead
;; it supports "jagged" arrays (i.e., arrays of references to other
;; arrays).  CL supports rectangular arrays by default, but there's
;; nothing stopping you from using jagged arrays instead, since CL
;; arrays can contain anything.  In this example we'll assume jagged
;; arrays, to match the Perl example's semantics.

;; You could go like this, but it is a lot of typing and is confusing
;; to read.
(setf (aref (aref (aref (aref a 4) 23) 53) 21) "fred")
(format t "~A" (aref (aref (aref (aref a 4) 23) 53) 21))
;; fred

;; An AREF-like macro to handle jagged arrays will save typing/errors.
(defmacro perl-aref (array &rest subscripts)
  "Allows AREF-like access to arrays-of-refrences (as opposed to true
multidimensional arrays.)"
  (labels ((make-arefs (array subscripts)
             (if subscripts
                 (make-arefs `(aref ,array ,(car subscripts)) (cdr subscripts))
                 array)))
    (make-arefs array subscripts)))

(setf (perl-aref a 4 23 53 21) "fred")
(format t "~A" (perl-aref a 4 23 53 21))
;; fred

;; Each of the following will print out the entire substructure.
(format t "~A" (perl-aref a 4 23 53))
(format t "~A" (perl-aref a 4 23))
(format t "~A" (perl-aref a 4))
;;;-----------------------------
(setf op-cit (or (cite ibid) (error "couldn't make a reference")))
;;;-----------------------------
;; MKHASH defined in appendix
(setf nat (mkhash "Name" "Leonhard Euler"
                  "Address" (format nil "1729 Ramanujan Lane~%Mathworld, PI 31416")
                  "Birthday" #x5bb5580))
;;;-----------------------------

;;;-----------------------------
(setf my-aref array) 
(setf anon-array #(1 3 5 7 9))
(setf anon-copy (copy-seq my-array))
(setf implicit-creation (copy-seq #(2 4 6 8 10))) ; not sure this is what the Perl means
;;;-----------------------------
(vector-push-extend 11 anon-array)      ; ANON-ARRAY must have fill pointer (unlike above)
;;;-----------------------------
(setf two (aref implicit-creation 0))
;;;-----------------------------
(setf last-idx (1- (length my-aref)))
(setf num-items (length my-aref))
;;;-----------------------------
;; check wehther SOMEREF contains a simple array reference
(check-type someref simple-vector) ; CHECK-TYPE does a die() implicitly, if necessary

(format t "~{~A~^ ~}~%" (coerce array-ref 'list))

;; SORT modifies the original array so we use STABLE-SORT to be more
;; like the Perl example.
(setf order (stable-sort array-ref '<))

;; Only works if ARRAY-REF has a fill-pointer
(setf array-ref (make-array 0 :adjustable t :fill-pointer 0)) ; for example
(vector-push-extend item array-ref)
;;;-----------------------------
(defun array-ref ()
  ;; This is probably the closest to what the Perl would return.
  (make-array 0 :adjustable t :fill-pointer 0))

(setf aref1 (array-ref))
(setf aref2 (array-ref))
;;;-----------------------------
(format t "~A" (aref array-ref n))      ; access item in position N, works on any array
(format t "~A" (svref array-ref n)) ; access item in position N, possibly fastest, only
                                    ; works on type SIMPLE-VECTOR (single-dimensional arrays)
(format t "~A" (elt array-ref n))       ; same, works on any sequence type, but possibly slower
;;;-----------------------------
(setf pie #(0 1 2 3 4 5 6 7 8 9))
(make-array 3 :displaced-to pie :displaced-index-offset 3) ; array slice
;;;-----------------------------
(setf (subseq pie 3 6) #("blackberry" "blueberry" "pumpkin")) ; note 6 instead of 5, not a typo
;;;-----------------------------
(setf sliceref (make-array 3 :displaced-to pie :displaced-index-offset 3)) ; not wrong
;;;-----------------------------
(map nil
     #'(lambda (item)
         ;; ITEM has data
         )
     array-ref)

(dotimes (idx (array-dimension array-ref 0))
  ;; (svref array-ref idx) has data
  )
;;;-----------------------------

;;;-----------------------------
;; Note: HASH must be creaed with :TEST 'EQUAL
(push "new value" (gethash "KEYNAME" hash))
;;;-----------------------------
(loop
   for string being the hash-keys of hash
   do (format t "~A: ~A~%" string (gethash string hash)))
;;;-----------------------------
(setf (gethash "a key" hash) #(3 4 5))  ; anonymous array
(setf (gethash "a key" hash) '(3 4 5))  ; ...or a list would work too
;;;-----------------------------
(setf values (gethash "a key" hash))
;;;-----------------------------
(push value (gethash "a key" hash))
;;;-----------------------------
(setf residents (gethash number phone2name)) ; will be NIL if not found
;;;-----------------------------
;; The Perl example would translate to the same thing as the previous
;; subsection in CL (since GETHASH returns NIL when there is no value,
;; and NIL is the empty list).  However, to match the "sprit" of the
;; Perl example (and return an empty array instead of an empty list),
;; you could do the following, which takes advantage of the fact that
;; GETHASH returns a second value indicating whether or not the hash
;; key actually has a value.
(setf residents (multiple-value-bind (value exists) (gethash number phone2name)
                  (if exists
                      value
                      #())))
;;;-----------------------------

;;;-----------------------------
(setf href hash)
(setf anon-hash (mkhash "key1" "value1" "key2" "value2" ...)) ; MKHASH defined in appendix

;; Couldn't find anything like this in standard CL.  Someone please
;; correct me if I'm wrong.
(defun copy-hash-table (hash-table)
  "Make shallow copy of HASH."
  (let ((newhash (make-hash-table :test (hash-table-test hash-table) 
                                  :size (hash-table-size hash-table))))
    (loop for key being the hash-keys of hash-table using (hash-value value)
         do (setf (gethash key newhash) (gethash key hash-table)))
    newhash))

(setf anonymous-hash-copy (copy-hash-table hash))
;;;-----------------------------
(setf hash href)
(setf value (gethash key href))

(setf slice (loop for key in (list key1 key2 key3)
                 collect (gethash key href)))
(setf keys (loop for key being the hash-keys of href collect key))
;;;-----------------------------
(check-type someref hash-table) ; CHECK-TYPE does a die() implicitly, if necessary
;;;-----------------------------
(dolist (href (list env inc)) ; ENV and INC don't exist in CL, just matching the Perl
  (loop for key being the hash-keys of href using (hash-value value)
       do (format t "~A => ~A~%" key value)))
;;;-----------------------------
(setf values (loop for key in '("key1" "key2" "key3")
                collect (gethash key hash-ref)))

;; The following will NOT work like the Perl example, VAL is a copy of
;; the hash value because numeric values are copied.
(dolist val (loop for key in '("key1" "key2" "key3")
               collect (gethash key hash-ref))
        (incf val 7))              ; does NOT modify hash table at all

;; You'd have to do something like this instead.
(loop for key in '("key1" "key2" "key3")
   do (incf (gethash key hash-ref 0) 7))
;;;-----------------------------
        

;;;-----------------------------
;; If you want to be able to call the function using the alias like
;; "normal" (i.e., as the first element of a form) SETF its
;; SYMBOL-FUNCTION:
(setf (symbol-function 'cref) #'func)
(setf (symbol-function 'cref) #'(lambda (...)))

;; If you do the following instead, you'll have to use APPLY and/or
;; FUNCALL.
(setf 'cref2 #'func)
(setf 'cref2 #'(lambda (...)))
;;;-----------------------------
(setf returned (cref ...))
;; If you have a list of arguments (more like the Perl example):
(setf returned (apply 'cref arguments))
;; Or you can use FUNCALL (not that you really need to in this case)
(setf returned (funcall 'cref ...))

;; If you didn't use SYMBOL-FUNCTION, then you can do the following:
(setf returned (apply cref arguments)) ; note the lack of a ' in front of CREF
(setf returned (funcall cref ...))      ; ditto
;;;-----------------------------
(defun thefunc ()
  ;; ...
  )
(setf funcname "THEFUNC")  ; upper-case to pick up correct symbol name
(funcall (intern funcname))
;;;-----------------------------
;; MKHASH defined in appendix
(defparameter *commands*
  (mkhash "happy" #'joy
          "sad" #'sullen
          "done" #'(lambda () (error "See ya!"))
          "mad" #'angry))

(format t "How are you?")
(let* ((string (chomp (read-line))) ; CHOMP defined in appendix
       (command (gethash string *commands*)))
  (if command
      (funcall command)
      (format t "No such command: ~A~%" string)))
;;;-----------------------------
(defun counter-maker ()
  (let ((start 0))
    #'(lambda ()
        (prog1 start                       ; return value of START prior to increment
          (incf start)))))

(setf (symbol-function 'counter) (counter-maker))

(loop repeat 5 do (format t "~A~%" (counter)))
;;;-----------------------------
(setf (symbol-function 'counter1) (counter-maker)
      (symbol-function 'counter2) (counter-maker))

(loop repeat 5 do (format t "~A~%" (counter1)))
(format t "~A ~A~%" (counter1) (counter2))
;; 0
;; 1
;; 2
;; 3
;; 4
;; 5 0
;;;-----------------------------
(defun timestamp ()
  (let ((start-time (get-universal-time)))
    #'(lambda ()
        (- (get-universal-time) start-time))))

(setf (symbol-function 'early) (timestamp))
(sleep 20)
(setf (symbol-function 'later) (timestamp))
(sleep 10)
(format t "It's been ~D seconds since early.~%" (early))
(format t "It's been ~D seconds since later.~%" (later))
;; It's been 30 seconds since early.
;; It's been 10 seconds since later.
;;;-----------------------------

;;;-----------------------------
;; Although you can't get a reference directly to the scalar that a
;; symbol points to (at least, not if it's a number or character), you
;; can just refer to the symbol itself, for largely the same effect.
(setf scalar-ref 'scalar)               ; get reference to symbol
;;;-----------------------------
;; Not sure what this was trying to demonstrate.
;;undef $anon_scalar_ref;
;;$$anon_scalar_ref = 15;
;;;-----------------------------
;; There's no way to do this in CL that I know of.
;;$anon_scalar_ref = \15;
;;;-----------------------------
(format t "~A" (symbol-value scalar-ref)) ; dereference it
(setf (symbol-value scalar-ref) (concatenate 'string (symbol-value scalar-ref) "string"))
;;;-----------------------------
;; This is a BAD idea in CL.  Symbols are relatively expensive, there
;; is no guarantee that name collisions won't happen, possible memory
;; leak issues, etc.
(let ((symbol-number -1))
  (defun new-anon-symbol ()
    (intern (format nil "_NEWANONSYM~D" (incf symbol-number)))))
;;;-----------------------------
(setf sref (new-anon-symbol)
      (symbol-value sref) 3)
(format t "Three = ~A~%" (symbol-value sref))
(setf my-array (vector (new-anon-symbol) (new-anon-symbol)))
(setf (symbol-value (svref my-array 0)) 6.02e23
      (symbol-value (svref my-array 1)) "avocado")
(format t "ARRAY contains: ~{~A~^, ~}~%" (map 'list 'symbol-value array))
;;;-----------------------------
(setf var (with-output-to-string (output)
            (sb-ext:run-program "uptime" nil :search t :output output)))
(setf vref 'var)
(when (scan "load" (symbol-value vref)))
(setf (symbol-value vref) (chomp (symbol-value vref)))
;;;-----------------------------
;; check whether SOMEREF contains a reference to a symbol, which we're
;; using instead of Perl's scalar references.
(check-type someref 'symbol)            ; does the die() for us
;;;-----------------------------

;;;-----------------------------
(setf array-of-scalar-refs (vector 'a 'b))
;;;-----------------------------
;; Note that because #() quotes its contents, A and B refer to the
;; symbols A and B, not their values, which is the closest
;; approximation to what the Perl is doing.
(setf array-of-scalar-refs #(a b))
;;;-----------------------------
(setf (symbol-value (aref array-of-scalar-refs 1)) 12) ; B = 12
;;;-----------------------------
(setq a 1 b 2 c 3 d 4)                  ; initialize
(setf my-array (vector 'a 'b 'c 'd))    ; refs to each symbol
(setf my-array #(a b c d))              ; same thing!
(setf my-array (loop repeat 4 collect (new-anon-symbol))) ; allocate 4 anon symbols

(incf (symbol-value (aref my-array 2)) 9) ; C now 12

(symbol-macrolet ((element (symbol-value (aref my-array (1- (length my-array))))))
  (setf element (* element 5))          ; D now 20
  (setf element (* element 5)))         ; D now 100

(let ((tmp (aref my-array (1- (length my-array)))))   ; using temporary
  (setf (symbol-value tmp) (* 5 (symbol-value tmp)))) ; D now 500
;;;-----------------------------
;; Note that PI is built in to CL.
(map 'nil 
     #'(lambda (sref)
         "Replace with spherical volumes."
         (symbol-macrolet ((element (symbol-value sref)))
           (setf element (* (expt element 3)
                            (* 4/3 pi)))))
     my-array)
;;;-----------------------------

;;;-----------------------------
(setf c1 (mkcounter 20)
      c2 (mkcounter 77))

(format t "next c1: ~d~%" (funcall (gethash "NEXT" c1))) ; 21 
(format t "next c2: ~d~%" (funcall (gethash "NEXT" c2))) ; 78 
(format t "next c1: ~d~%" (funcall (gethash "NEXT" c1))) ; 22 
(format t "last c1: ~d~%" (funcall (gethash "PREV" c1))) ; 21 
(format t "old  c2: ~d~%" (funcall (gethash "RESET" c2))) ; 77
;;;-----------------------------
(defun mkcounter (start)
  (let* ((count start)
         (bundle
          ;; MKHASH defined in appendix
          (mkhash 
           "NEXT"   #'(lambda () (incf count))
           "PREV"   #'(lambda () (decf count))
           "GET"    #'(lambda () count)
           "SET"    #'(lambda (new-count) (setf count new-count))
           "BUMP"   #'(lambda (delta) (incf count delta))
           "RESET"  #'(lambda () (setf count start)))))
    (setf (gethash "LAST" bundle) (gethash "PREV" bundle))
    bundle))
;;;-----------------------------

;;;-----------------------------
;; Methods in CL are generic functions that can be specialized on any
;; of their arguments.  The technique that the Perl code is using to
;; allow calling meth() without the $obj-> is needless in CL.  You can
;; make a reference to a method, the same way you might make a
;; referece a normal function.  There's not much point in doing this,
;; normally.
(setf (symbol-function 'mref) #'meth)
;; later...
(mref "args" "go" "here")
;;;-----------------------------
(setf (symbol-funtion 'sref) #'meth)
;;;-----------------------------

;;;-----------------------------
;; MKHASH defined in appendix
(setf record (mkhash
              :name    "Jason"
              :empno   132
              :title   "deputy peon"
              :age     23
              :salary  37000
              :pals    '("Norbert" "Rhys" "Phineas")))

(format t "I am ~A, and my pals are ~{~A~^, ~}~%"
        (gethash :name record)
        (gethash :pals record))
;;;-----------------------------
(defparameter *byname* (make-hash-table :test 'equal))
;; store record
(setf (gethash (gethash :name record) *byname*) record)

;; later on, look up by name
(let ((rp (gethash "Aron" *byname*)))
  (when rp
    (format t "Aron is employee number ~D~%" (gethash :empno rp))))

;; give jason a new pal
(push "Theodore" (gethash :pals (gethash "Jason" *byname*)))
(format t "Jason now has ~D pals~%" (length (gethash :pals (gethash "Jason" *byname*))))
;;;-----------------------------
;; Go through all records
(maphash #'(lambda (name record)
             (format t "~A is employee number ~D~%" name (gethash :empno record)))
         *byname*)
;;;-----------------------------
;; store record
(defparameter *employees* (make-array 0 :adjustable t))
(let ((empno (gethash :empno record)))
  (unless (array-in-bounds-p *employees* empno)
    ;; :INITIAL-ELEMENT used to prevent array from being extended with 0's
    (adjust-array *employees* (1+ empno) :initial-element nil))
  (setf (aref *employees* empno) record))

;; lookup by id
(when-let (rp (aref *employees* 132))
  (format t "employee 132 is ~A~%" (gethash :name rp)))
;;;-----------------------------
;; The use of SYMBOL-MACROLET saves us from repeating a complicated
;; expression multiple times.  Could also define a macro to make this
;; easier.
(symbol-macrolet ((salary (gethash :salary (gethash "Jason" *byname*))))
  (setf salary (* salary 1.035)))
;;;-----------------------------
(setf peons (remove-if-not
             #'(lambda (employee)
                 (and employee
                      (scan (create-scanner "peon" :case-insensitive-mode t)
                                     (gethash :title employee))))
             *employees*))
;; Or:
(setf peons (perl-grep *employees*
              (and it
                   (scan (create-scanner "peon" :case-insensitive-mode t)
                                  (gethash :title it)))))

(setf tsevens (remove-if-not 
               #'(lambda (employee) 
                   (and employee
                        (= (gethash :age employee) 
                           27)))
               *employees*))
;;;-----------------------------
(defun hash-slice (hash &rest keys)
  "Meant to emulate Perl's built-in hash slicing feature."
  (loop for key in keys collect (gethash key hash)))

(dolist (rp (sort (loop for v being the hash-values of *byname* collect v)
                 'string-lessp
                 :key #'(lambda (hash) (gethash :age hash))))
  (format t "~A is employee number ~D.~%" (gethash :name rp) (gethash :age rp))
  ;; or with a hash slice on the reference (note that we're using the
  ;; non-standard HASH-SLICE function defined above, whereas Perl
  ;; has a built-in to do it).
  (apply 'format t "~A is employee number ~D.~%" (hash-slice rp :name :age)))
;;;-----------------------------
;; use BYAGE, an array of lists of records
(push record (aref *byage* (gethash :age record)))
;;;-----------------------------
(dotimes (age (length *byage*))
  (when-let (records (aref *byage* age))
    (format t "Age ~D: " age)
    (dolist (rp records)
      (format t "~A " (gethash :name rp)))
    (format t "~%")))
;;;-----------------------------
(dotimes (age (length *byage*))
  (when-let (records (aref *byage* age))
    (format t "Age ~D: ~{~A~^, ~}~%" age (map 'list #'(lambda (employee)
                                                        (gethash :name employee))
                                              (aref *byage* age)))))
;;;-----------------------------

;;;-----------------------------
;; FieldName: Value
;;;-----------------------------
;; Using list instead of array since random access not required.
(defparameter *list-of-records* nil)

(map nil #'(lambda (record)
             (dolist (key (sort (loop for k being the hash-keys of record collect k)
                                'string-lessp :key 'symbol-name))
               (format t "~A: ~A~%" key (gethash key record)))
             (terpri))                  ; same as (format t "~%")
     *list-of-records*)
;;;-----------------------------
;; GET-PARAGRAPH defined above
(dolist (filename filenames)
  (with-open-file (file filename)
    (loop
       for paragraph = (get-paragraph file)
       until (string-equal paragraph "")
       do
       (let ((fields
              (split (create-scanner "^([^:]+):\\s*" :multi-line-mode t)
                              paragraph :with-registers-p t)))
         (push (apply 'mkhash (cdr fields)) *list-of-records*)))))
;;;-----------------------------

;;;-----------------------------

;;; Binary trees example
(deftype tree () '(or null tree-node))
(defstruct (tree-node
             (:conc-name #:tree-))
  value
  ;; subtrees
  (left nil :type tree)
  (right nil :type tree))

(defun tree-insert (tree value)
  "Return TREE with destructively inserted VALUE."
  (declare (type tree tree))
  (if tree
      (progn (if (< value (tree-value tree))
                 (setf (tree-left tree)
                       (tree-insert (tree-left tree) value))
                 (setf (tree-right tree)
                       (tree-insert (tree-right tree) value)))
             tree)
      (make-tree-node :value value)))

(defun print-tree-in-order (tree)
  (when tree
    (print-tree-in-order (tree-left tree))
    (format t "~S " (tree-value tree))
    (print-tree-in-order (tree-right tree))))

(defun print-tree-in-preorder (tree)
  (when tree
    (format t "~S " (tree-value tree))
    (print-tree-in-preorder (tree-left tree))
    (print-tree-in-preorder (tree-right tree))))

(defun print-tree-in-postorder (tree)
  (when tree
    (print-tree-in-postorder (tree-left tree))
    (print-tree-in-postorder (tree-right tree))
    (format t "~S " (tree-value tree))))

(defun search-tree (tree value)
  "Return a subtree of TREE with the specified VALUE in root."
  (when tree
    (if (= (tree-value tree) value)
        tree
        (search-tree (if (< value (tree-value tree))
                         (tree-left tree)
                         (tree-right tree))
                     value))))

(defun test-trees ()
  (let ((tree nil))
    (dotimes (i 20)
      (setf tree (tree-insert tree (random 1000))))
    (format t "~&Pre order: ") (print-tree-in-preorder tree)
    (format t "~&In order:  ") (print-tree-in-order tree)
    (format t "~&Postorder: ") (print-tree-in-postorder tree)
    (terpri)

    (loop do
         (format t "~&Search? ")
         (finish-output)
         (let* ((eof (gensym)) ; some hard-to-enter object
                (value (read *standard-input* nil eof)))
           (when (eq value eof) (loop-finish))
           (let ((found (search-tree tree value)))
             (if found
                 (format t "Found ~S at ~S~%" value found)
                 (format t "No ~S in tree~%" value)))))))
;;;-----------------------------