Notes on Exam 2: Intermediate Scheme

(define jacks-desires
  '((characteristic "cute")
    (characteristic "smart")
    (eyecolor "blue")
    (eyecolor "hazel")
    (height 70)
    (height 71)
    (height 72)
    (height 73)
    (likes "computer science")
    (likes "voting")))

;;; Procedure:
;;;   intro
;;; Parameters:
;;;   (none)
;;; Purpose:
;;;   Prints out an introduction.
;;; Produces:
;;;   Nothing
;;; Preconditions:
;;;   Still able to write to standard output.
;;; Postconditions:
;;;   Has printed some text.
(define intro
  (lambda ()
    (display "Soon I will ask you to describe your ideal date.")
    (newline)
    (display "If you want to give a multiple-word response to any.")
    (newline)
    (display "question, you will need to surround that response with")
    (newline)
    (display "quotation marks.")
    (newline)
    (display "  I will ask you for eye color, hair color, weight, ")
    (newline)
    (display "height, age, and other characteristics.")
    (newline)
    (display "  I will also ask you for a list of things you'd like")
    (newline)
    (display "your date to like")
    (newline)))

What kind of desire would you like to enter? 
  (eyecolor, agerange, characteristic, etc): eyecolor
What eyecolor would you like? red
Are there other desires you'd like to enter? yes
What kind of desire would you like to enter? 
  (eyecolor, agerange, characteristic, etc): agerange
What is the youngest age you'll date? twenty-something
I'm sorry, I only understand numbers.
What is the youngest age you'll date? 20
What is the oldest age you'll date? 30
Are there other desires you'd like to enter? no
Here's the result:
((eyecolor red)
 (agerange 20 30))

Please enter an eyecolor (or X to stop): red
Please enter an eyecolor (or X to stop): blue
Please enter an eyecolor (or X to stop): X
Please enter a minimum weight: 0
Please enter a minimum height (or 0 to stop): 72
Please enter a height (or 0 to stop): 0
...
Here's the result:
((eyecolor red)
 (eyecolor blue)
 (height 72))

    (letrec ((helper (lambda () 
                       ; Read one desire
                       (let ((desire (read-one-desire)))
                       ; Check if the client wishes to enter other desires
                       (if (ask-yes-no "Do you wish to enter any other desires? ")
                           ; Yes.  Recurse.
                           (cons desire (helper))
                           ; No.  Return a one element list.
                           (cons desire null))))))

      (intro)
      (helper)

;;; Procedure:
;;;   read-one-desire
;;; Parameters:
;;;   (none)
;;; Purpose:
;;;   Reads one desire, prompting for the type of desire as well
;;;   as the particular desire.
;;; Produces:
;;;   A desire, in the standard format.
;;; Preconditions:
;;;   Able to read input and write output.
;;; Postconditions:
;;;;  Returns a desire in the appropriate format.
(define read-one-desire 
  (lambda () 
     ; Determine the category
     (let ((category (read-symbol 
                      (string-append
                        "What kind of desire do you wish to enter?"
                        (string #\newline)
                        "  ")
                      (list 'eyecolor 'haircolor 'height 'weight 
                            'age 'characteristic 'like))))
        ; Which category is it?
        (cond
          ; Eye color
          ((equal? category 'eyecolor)
           (list 'eyecolor
                 (read-string "What eye color do you like? ")))
          ; Hair color
          ((equal? category 'haircolor)
           (list 'haircolor
                 (read-string "What hair color do you like? ")))
          ; Age range
          ((equal? category 'age) (read-age-range))
          ; Height range
          ((equal? category 'height) (read-height-range))
          ; Weight range
          ((equal? category 'weight) (read-weight-range))
          ; Other characteristic
          ((equal? category 'characteristic)
           (list 'characteristic
                 (read-string "What characteristic are you looking for? ")))
          ; A like
          ((equal? category 'like)
           (list 'likes
                 (read-string "What do you want your date to like? ")))
          ; Default.  This should not happen.
          (else
           (begin
             (display "I can't understand ")
             (display (symbol->string category))
             (display ".")
             (newline)
             (list 'unknown category)))))))

;;; Procedure
;;;   read-age-range
;;; Parameters:
;;;   (none)
;;; Purpose:
;;;   Reads a range of ages.
;;; Produces:
;;;   A list of the form ('agerange number number).
;;; Preconditions:
;;;   Possible to read input and write output.
;;; Postconditions:
;;;   Reads input, writes output.
;;;   Result is in the appropriate form.
;;; Note:
;;;   Does not verify that the younger age is smaller than the
;;;   older age.
(define read-age-range
  (lambda ()
     (let* ((youngest (read-positive-number
                       "What is the youngest age you'd like to date? "))
            (oldest (read-positive-number
                     "What is the oldest age you'd like to date? ")))
        (list 'agerange youngest oldest))))

;;; Procedure:
;;;   read-desires-two
;;; Parameters:
;;;   Reads a list of desires, one by one.  Reads all the responses
;;;   for each kind of desires before going on to the next.
;;; Produces:
;;;   A potentially-empty list of desires.
;;; Preconditions:
;;;   It is currently possible to read input and print output.
;;; Postconditions:
;;;   Has read some input and printed some output.
(define read-desires-two
  (lambda ()
    (intro)
    (append
      (list
        (read-age-range)
        (read-height-range)
        (read-weight-range))
      (map (lambda (color) (list 'eyecolor color))
           (read-string-list "What eye color do you like (x to stop)? " "x"))
      (map (lambda (color) (list 'hair color))
           (read-string-list "What hair color do you like (x to stop)? " "x"))
      (map (lambda (thing) (list 'characteristic thing))
           (read-string-list "What other characteristic are you looking for (x to stop)? " "x"))
      (map (lambda (like) (list 'likes like))
           (read-string-list "What would you like your date to like (x to stop)? " "x")))))
    

> (define me 
    '("John" "Doe" male both 33
      ((height 66) "handsome" "creative" "smart")
      ("fast cars" "lego" "computer science")
      ((characteristic "cute")
       (characteristic "smart")
       (eyecolor "blue")
       (eyecolor "hazel")
       (height 70)
       (height 71)
       (height 72)
       (height 73)
       (likes "computer science"))))
> (suggest-dates me datees)

;;; Procedure:
;;;   same-person?
;;; Purpose:
;;;   Determine if two people are the same.
;;;   Currently, that the two people have the same name, but that
;;;   may change.
;;; Parameters:
;;;   Two people in the appropriate form.
;;; Returns:
;;;   #t, if they are; #f otherwise.
;;; Preconditions:
;;;   All people are in the approved form.
;;; Postconditions:
;;;   Does not affect the parameters.
(define same-person?
  (lambda (person1 person2)
    (equal? (get-datee-full-name person1)
            (get-datee-full-name person2))))

(define same-person?
  (lambda (person1 person2)
    (if (equal? (get-datee-full-name person1)
               (get-datee-full-name person2))
        #t
        #f)))

if the two people match, return true

;;; Procedure:
;;;   join-likes
;;; Parameters:
;;;   A list of datees
;;; Produces:
;;;   A list of likes with potential duplicates.
;;; Preconditions:
;;;   The list of datees is in the approved format.  In
;;;   particular, (list-ref datee 6) gives a list of likes.
;;; Postconditions:
;;;   Returns a list of strings representing all possible likes.
;;;   If a string appears in some list of likes, it appears in
;;;     that list.
;;;   If a string appears in the result list, it appears in some
;;;     list of likes.
(define join-likes
  (lambda (datees)
    ; If no one is left in our list, there are no likes.
    (if (null? datees) null
    ; Otherwise, join this person's likes to the remaining likes
        (append (list-ref (car datees) 6) (join-likes (cdr datees))))))

(define join-likes
  (lambda (datees)
    (apply append (map (lambda (datee) (list-ref datee 6)) datees))))

;;; Procedure:
;;;   remove-duplicates
;;; Parameters:
;;;   A list of strings.
;;; Purpose: 
;;;   Remove duplicate entries.
;;; Produces:
;;;   A list of strings with no duplicate entries.
;;; Preconditions:
;;;   The parameter is a list of strings. [Unverified]
;;; Postconditions:
;;;   Returns a list of strings.
;;;   No string appears twice in the result list.
;;;   Every string in the original list appears in the result list.
;;;   Every string in the result list appeared in the original list.
(define remove-duplicates
  (lambda (lst)
    ; The empty list has no duplicates
    (if (null? lst) null
        ; Otherwise, get the first element and remove duplicates from the rest.
        (let ((first (car lst))
              (rest (remove-duplicates (cdr lst))))
          ; If the first element is in the rest of the list, don't use it.
          (if (member first rest) rest
          ; Otherwise, do use it.
              (cons first rest))))))

(define remove-duplicates
  (lambda (lst)
    ; The empty list has no duplicates
    (if (null? lst) null
        ; Otherwise, remove copies of the first element from the rest.
        (cons (car lst) 
              (remove-duplicates (remove-copies (car lst) (cdr lst)))))))    

;;; Procedure:
;;;   remove-copies
;;; Parameters:
;;;   A string, removeMe
;;;   A list of strings, strings
;;; Purpose:
;;;   Removes all copies of a value from a list.
;;; Produces:
;;;   A list of strings.
;;; Preconditions:
;;;   The parameter is a list of strings.
;;; Postconditions:
;;;   The result list contains only strings.
;;;   The result list does not contain removeMe.
;;;   Every value (other than removeMe) that appeared in strings appears
;;;    in the result.
;;;   Every value that appears in the result appeared in strings.
(define remove-copies
  (lambda (removeMe strings)
    (cond ((null? strings) null)
          ((equal? removeMe (car strings)) (remove-copies removeMe (cdr strings)))
          (else (cons (car strings)
                      (remove-copies removeMe (cdr strings)))))))

(define remove-duplicates
  (lambda (lst)
    (letrec ((helper (lambda (vals acc)
                       (cond ((null? vals) (reverse acc))
                             ((member (car vals) acc) (helper (cdr vals) acc))
                             (else (helper (cdr vals) (cons (car vals) acc)))))))
      (helper lst null))))

(define list-likes
  (lambda (datees)
    (letrec
      (
       ; Helper one: join-likes
       (join-likes (lambda (datees)
                         (apply append 
                                (map (lambda (datee) (list-ref datee 6)) 
                                     datees))))
       ; Helper two: remove-dupes lst acc
       (remove-dupes (lambda (vals acc)
                       (cond ((null? vals) (reverse acc))
                             ((member (car vals) acc) (remove-dupes (cdr vals) acc))
                             (else (remove-dupes (cdr vals) (cons (car vals) acc)))))))
      ; Okay, go for it!
      (remove-dupes (join-likes datees) null))))

;;; Procedure:
;;;   count-chars
;;; Parameters:
;;;   A predicate
;;;   A string
;;; Purpose:
;;;   Counts all the characters in the string that meet the predicate.
;;; Produces:
;;;   A count of all such characters (an integer).
;;; Preconditions:
;;;   The predicate maps characters to boolean values.
;;;   The string is a string.
;;; Postconditions:
;;;   Counts correctly.
(define count-chars
  (lambda (pred? str)
    (letrec ((helper (lambda (pos ; Current position in the string.
                              max ; Last position in the string.
                              count) ; How many characters already matched.
                       (cond
                         ; If we've finished the string, stop.
                         ((> pos max) count)
                         ; If the first character meets the predicate, add 1
                         ((pred? (string-ref str pos)) 
                          (helper (+ 1 pos) max (+ 1 count)))
                         ; Otherwise, just look at the rest.
                         (else (helper (+ 1 pos) max count))))))
      (helper 0                         ; Start at the front
              (- (string-length str) 1) ; Stop at the last character.  Since 0-based,
                                        ;   stop one before the end.
              0))))                     ; Haven't seen anything yet.

;;; Procedure:
;;;   count-punc
;;; Parameters:
;;;   A string
;;; Purpose:
;;;   Counts all punctuation characters in the string.
;;; Produces:
;;;   A count of all punctuation (an integer).
;;; Preconditions:
;;;   The string is a string.
;;; Postconditions:
;;;   Counts correctly.
;;; Note:
;;;   Uses the following punctuation:
;;;   * apostrophe ('),
;;;   * colon (:),
;;;   * comma (,),
;;;   * quotation mark ("),
;;;   * exclamation point (!),
;;;   * parentheses (( and )),
;;;   * period (.),
;;;   * question mark (?), and
;;;   * semi-colon (;).
(define count-punc
  (lambda (str)
    (let ((punc (string->list "':,\"!().?;")))
      (count-chars (lambda (ch) (member ch punc)) str))))

> (split "Hello there you fool" " ")
("Hello" "there" "you "fool")
> (split "alpha,beta,gamma" ",")
("alpha" "beta" "gamma")
> (split "fufie fubar fun" "fu")
("" "fie " "bar " "n")

;;; Procedure:
;;;   find-index
;;; Parameters:
;;;   A pattern string.
;;;   A source strng.
;;; Purpose:
;;;   Finds the index of the pattern string in the source string.
;;; Produces:
;;;   The index of the first match of the pattern within the source,
;;;      if the pattern falls within the source.
;;;   -1, otherwise
;;; Preconditions:
;;;   Both parameters are strings.
;;; Postconditions:
;;;   If the result is not -1 then it is the first value, i, such
;;;   that the substring of source beginning at i of length equal  
;;;   to the length of pattern is the same as pattern).
(define find-index
  (lambda (pattern source)
    ; Remember some key values for efficiency
    (let ((plen (string-length pattern))
          (slen (string-length source)))
      ; Helper procedure.  Keeps track of where we're looking.
      (let helper ((index 0)) ; The index we're currently checking.
        (cond
          ; If there are too few characters left, give up
          ((< (- slen index) plen) (- 0 1))
          ; If the current substring matches, return its index
          ((equal? (substring source index (+ index plen)) pattern) index)
          ; Otherwise, advance to the next thing.
          (else (helper (+ index 1))))))))

(substring source 0 split-index)

(substring source (+ split-index (string-length splitter))
                  (string-length source))

; Procedure:
;;;   split
;;; Parameters:
;;;   source, a string
;;;   splitter, a string
;;; Purpose:
;;;   Split the source at every occurence of the splitter.
;;; Produces:
;;;   A list of strings.
;;; Preconditions:
;;;   Both parameters are strings.
;;; Postconditions:
;;;   Affects neither string.
;;; Examples:
;;;   > (split "Hello there you fool" " ")
;;;   ("Hello" "there" "you "fool")
;;;   > (split "alpha,beta,gamma" ",")
;;;   ("alpha" "beta" "gamma")
;;;   > (split "fufie fubar fun" "fu")
;;;   ("" "fie " "bar " "n")
;;;   > (split "me and you and a dog named boo" " and ")
;;;   ("me" "you" "a dog named boo")
(define split
  (lambda (source splitter)
    ; (1) Find the index of the splitter in the source.
    (let ((split-index (find-index splitter source)))
      ; (2) If the splitter is not in the source (indicated by a
      ;     index of -1), just return a list containing the source.
      (if (= split-index -1) (list source)
          ; Otherwise, split at the splitter and recurse
          (cons (substring source 0 split-index)
                (split (substring source
                                  (+ split-index (string-length splitter))
                                  (string-length source))
                       splitter))))))