emacs.d/CL-gentle-intro/array-hash-tables-plists.lisp

;;; Chapter 13 - Arrays, Hash Tables, And Property Lists

;;; Exercises

;;; Ex 13.1
;;; Write a function called SUBPROP that deletes an element from a set stored under a property name. 
;;; For example, if the symbol ALPHA has the list (A B C D E) as the value of its FOOPROP property, doing (SUBPROP 'ALPHA 'D 'FOOPROP) should leave (A B C E) as the value of ALPHA's FOOPROP property.
(setf (get 'alpha 'fooprop) '(a b c d e))

(defun subprop (name element prop)
  (setf (get name prop)
        (remove element
                (get name prop))))

;;; Ex 13.2
;;; Write a function called FORGET-MEETING that forgets that two particular persons have ever met each other.
;;; Use SUBPROP in your solution.
(defun addprop (sym elem prop)
  (pushnew elem (get sym prop)))

(defun record-meeting (x y)
  (addprop x y 'has-met)
  (addprop y x 'has-met)
  t)

(symbol-plist 'john)

(defun forget-meeting (x y)
  (remprop x 'has-met)
  (remprop y 'has-met)
  t)

;;; Alternative solution
(defun forget-meeting (person1 person2)
  (subprop person1 person2 'has-met)
  (subprop person2 person1 'has-met)
  'forgotten)

;;; Ex 13.3
;;; Using SYMBOL-PLIST, write your own version of the GET function.
(defun my-get (symbol property)
  (do ((p (symbol-plist symbol) (cddr p)))
      ((null p) nil)
    (if (equal property (first p))
        (return (second p)))))


;;; Ex 13.4
;;; Write a predicate HASPROP that returns T or NIL to indicate whether a symbol has a particular property, independent of the value of that property.
;;; Note: If symbol A has a property FOO with value NIL, (HASPROP 'A 'FOO) should still return T.
(defun hasprop (symbol property)
  (do ((p (symbol-plist symbol) (cddr p)))
      ((null p) nil)
    (if (equal property (first p))
        (return t))))

;;; Ex 13.8
;;;  Follow the steps below to create a histogram-drawing program. Your functions should not assume that the histogram will have exactly eleven bins.
;;; In other words, don't use eleven as a constant in you program; use (LENGTH *HIST-ARRAY*) instead.
;;; That way your program will be able to generate histograms of any size.

;;; a.
;;; Write expressions to set up a global variable *HIST-ARRAY* that holds the array of counts, and a global variable *TOTAL-POINTS* that holds the number of points recorded so far.
(setf *hist-array* nil)

(setf *total-points* 0)

;;; b.
;;; Write a function NEW-HISTOGRAM to initialize these variables appropriately.
;;; It should take one input: the number of bins the histogram is to have. 
(defun new-histogram (n)
  (setf *total-points* 0)
  (setf *hist-array* 
        (make-array n 
                    :initial-element 0))
  t)

;;; c.
;;; Write the function RECORD-VALUE that takes a number as input.
;;; If the number is between zero and ten, it should increment the appropriate element of the array, and also update *TOTAL-POINTS*.
;;; If the input is out of range, RECORD-VALUE should issue an appropriate error message.
(defun record-value (n)
  (cond ((or (< n 0) (> n 10))
         (format t "~&Number ~A is out of range." n))
        (t (setf (aref *hist-array* n)
                 (+ (aref *hist-array* n) 1))
           (dotimes (i 11 *total-points*)
             (setf *total-points* 
                   (+ *total-points* 
                      (aref *hist-array* i)))))))

;;; Better alternative
(defun record-value (v)
  (incf *total-points*)
  (if (and (>= v 0)
           (< v (length *hist-array*)))
      (incf (aref *hist-array* v))
      (error "Value ~S out of bounds." v)))

;;; d.
;;; Write a function PRINT-HIST-LINE that takes a value from zero to ten as input, looks up that value in the array, and prints the corresponding line of the histogram.
;;; To get the numbers to line up in columns properly, you will need to use the format directives ~2S to display the value and ~3S to display the count. 
;;; You can use a DOTIMES to print the asterisks.
(defun print-hist-line (n)
  (let ((cnt (aref *hist-array* n)))
    (format t "~&~2D [~3D] " n cnt)
    (dotimes (i cnt)
      (format t "*"))))

;;; e.
;;; Write the function PRINT-HISTOGRAM.
(defun print-histogram (iterations)
  (new-histogram 11)
  (dotimes (i iterations)
    (record-value (random 11)))
  (dotimes (i 11)
    (print-hist-line i))
  (format t "~&    ~3D total" *total-points*))

;;; Ex 13.9
;;; Set up the global variable CRYPTO-TEXT as shown. Then build the cryptogram-solv§ing tool by following these instruction:

;;; a.
;;; Each letter in the alphabet has a corresponding letter to which it deciphers, for example, P deciphers to A.
;;; As we solve the cryptogram we will store this information in two hash tables called *ENCIPHER-TABLE* and *DECIPHER-TABLE*.
;;; We will use *DECIPHER-TABLE* to print out the deciphered cryptogram.
;;; We need *ENCIPHER-TABLE* to check for two letters being deciphered to the same thing, for example, if P is deciphered to A and then we tried to decipher K to A, a look at *ENCIPHER-TABLE* would reveal that A had already been assigned to P.
;;; Similarly, if P is deciphered to A and then we tried deciphering P to E, a look at *DECIPHER-TABLE* would tell us that P had already been deciphered to A.
;;; Write expressions to initialize these global variables.
(setf *decipher-table* (make-hash-table))

(setf *encipher-table* (make-hash-table))

(setf crypto-text
      '("zj ze kljjls jf slapzi ezvlij pib kl jufwxuj p hffv jupi jf"
        "enlpo pib slafml pvv bfwkj"))

;;; b.
;;; Write a function MAKE-SUBSTITUTION that takes two character objects as input and stores the appropriate entries in *DECIPHER-TABLE* and *ENCIPHER-TABLE* so that the first letter deciphers to the second and the second letter enciphers to the first.
;;; This function does not need to check if either letter already has an entry in these hash tables.
(defun make-substitution (a b)
  (setf (gethash a *decipher-table*) b)
  (setf (gethash b *encipher-table*) a))

;;; c.
;;; Write a function UNDO-SUBSTITUTION that takes one letter as input. 
;;; It should set the *DECIPHER-TABLE* entry of that letter, and the *ENCIPHER-TABLE* entry of the letter it deciphered to, to NIL.
(defun undo-substitution (a b)
  (setf (gethash a *decipher-table*) nil)
  (setf (gethash b *encipher-table*) nil))

;;; d.
;;; Look up the documentation for the CLRHASH function, and write a function CLEAR that clears the two hash tables used in this problem.
(defun clear ()
  (clrhash *decipher-table*)
  (clrhash *encipher-table*)
  'clear-ok)

;;; e.
;;; Write a function DECIPHER-STRING that takes a single encoded string as input and return a new, partially decoded string. It should begin by making a new string the same length as the input, containing all spaces.
;;; Here is how to do that, assuming the variable LEN holds the length: (make-string len :initial-element #\Space).
;;; Next the function should iterate through the elements of the input string, which are character objects. For each character that deciphers to something non-NIL, that value should be inserted into the corresponding position in the new string.
;;; Finally, the function should return the new string.
;;; When testing this function, make sure its inputs are all lowercase. 
(defun decipher-string (str)
  (do* ((len (length str)) 
        (new-str (make-string len 
                              :initial-element #\Space))
        (i 0 (1+ i)))
       ((equal i len) new-str)
    (let* ((char (aref str i))
           (new-char 
             (gethash char *decipher-table*)))
      (when new-char
        (setf (aref new-str i) new-char))))) 

;;; f.
;;; Write a function SHOW-LINE that displays one line of cryptogram text, with the deciphered text displayed beneath it.
(defun show-line (line)
  (format t "~&~A" line)
  (format t "~&~A"
          (decipher-string line)))

;;; g.
;;; Write a function SHOW-TEXT that takes a cryptogram (list of strings) as input and displays the lines as in the examples at the beginning of this exercise.
(defun show-text (cryptogram)
  (format t "~&-------------------------------------")
  (dolist (element cryptogram)
    (format t "~&~A" element)
    (format t "~&~A" (decipher-string element)))
  (format t "~&-------------------------------------"))

;;; h.
;;; Type in the definition of GET-FIRST-CHAR, which returns the first character in the lowercase printed of an object.
(defun get-first-char (x)
  (char-downcase
   (char (format nil "~A" x) 0)))

;;; i.
;;; Write a function READ-LETTER that reads an object from the keyboard. If the object is the symbol END or UNDO, it should be returned as the value of READ-LETTER.
;;; Otherwise READ-LETTER should use GET-FIRST-CHAR on the object to extract the first character of its printed representation; it should return that character as its result.
(defun read-letter ()
  (do ((answer nil))
      (nil)
    (setf answer (read))
    (if (or (equal answer 'end)
            (equal answer 'undo))
        (return answer)
        (return (get-first-char answer)))))

;;; j.
;;; Write a function SUB-LETTER that takes a character object as input. If that character has been deciphered already, SUB-LETTER should print an error message that tells to what the letter has been deciphered.
;;; Otherwise SUB-LETTER should ask "What does (letter) decipher to?" and read a letter. 
;;; If the result is a character and it has not yet been enciphered, SUB-LETTER should call MAKE-SUBSTITION to record the substitution.
;;; Otherwise an appropriate error message should be printed.
(defun sub-letter (c)
  (let ((deciphered (gethash c *decipher-table*)))
    (cond ((not (null deciphered)) (format t 
                                     "~&´~A´ has already been deciphered as ´~A´" 
                                     c deciphered))
        (t (format t "~&What does ´~A´ decipher to? " c)
           (setf answer (read))
           (setf answer (get-first-char answer))
           (setf deciphered (gethash answer *decipher-table*))
           (if deciphered
               (format t "~&´~A´ has already been deciphered as ´~A´" 
                       answer deciphered)
               (make-substitution c answer))))))

;;; k.
;;; Write a function UNDO-LETTER that asks "Undo which letter?" and reads in a character.
;;; If that character has been deciphered UNDO-LETTER should call UNDO-SUBSTITUTION on the letter.
;;; Otherwise an appropriate error message should be printed.
(defun undo-letter ()
  (format t "~&Undo which letter? ")
  (let* ((l (read))
         (l (get-first-char l))
         (d (gethash l *decipher-table*)))
    (if d
        (undo-substitution l d)
        (format t "~&´~A´ cannot be undone." l))))

;;; Write the main function SOLVE that takes a cryptogram as input. SOLVE should perform the following loop.
;;; First it should display the cryptogram. 
;;; Then it should ask "Substitute which letter?" and call READ-LETTER.
;;; If the result is a character, SOLVE should call SUB-LETTER; if the result is the symbol UNDO, it should call UNDO-LETTER;
;;; If the result is the symbol END, it should return T;
;;; otherwise it should issue an error message.
;;; Then it should go back to the beginning of the loop, unless the value returned by READ-LETTER was END.
(defun solve (cryptogram)
  (clear)
  (show-text cryptogram)
  (do ((answer nil))
      (nil)
    (format t "~&Substitute which letter? ")
    (setf answer (read-letter))
    (cond ((equal answer 'undo) 
           (undo-letter)
           (show-text cryptogram))
          ((equal answer 'end) (return t))
          (t (sub-letter answer)
             (show-text cryptogram)))))