guile-paip/02-code.scm

(import
 (except (rnrs base) let-values map error)
 (only (guile)
       lambda* λ
       current-output-port)
 (srfi srfi-1))

;; =======
;; CHANGES
;; =======

;; This section lists differences to the book's code.

;; Some procedures have been renamed for better readability and compatibility
;; reasons:

;; elt -> element
;; random-elt -> random-element
;; car -> car/nil
;; mappend -> map-append

;; ===============================
;; Common Lisp compatibility layer
;; ===============================
(define NIL '())

(define element list-ref)

(define car/nil
  (λ (possibly-empty-list)
    "In Common Lisp car of an empty list returns the empty list
called NIL. In Scheme it would be an error to call car on an
empty list. We write a wrapper, to avoid an error."
    (cond
     [(null? possibly-empty-list) NIL]
     [else (car possibly-empty-list)])))

(define rest
  (λ (lst)
    (cond
     [(null? lst) NIL]
     [else (cdr lst)])))

(define assoc
  (λ (key alist)
    (let ([res (assoc key alist)])
      (cond
       [res res]
       [else NIL]))))

;; =================
;; HELPER PROCEDURES
;; =================
(define displayln
  (lambda* (#:key (output-port (current-output-port)) . msgs)
    (display (string-append
              (string-join
               (map (λ (msg) (simple-format #f "~s" msg)) msgs)
               " ") "\n")
             output-port)))

;; ======================
;; from previous chapters
;; ======================
(define map-append
  (λ (proc lst)
    (apply append (map proc lst))))

;; ==============================
;; 2-02-straight-forward-solution
;; ==============================

;; helper functions
(define random-element
  (λ (choices)
    (element choices (random (length choices)))))

(define one-of
  (λ (set)
    "Choose one element of a given set of elements and return
it. one-of returns a list, so that the result can be
appended to any other result."
    (list (random-element set))))

;; define the over all sentence structure
(define sentence
  (λ ()
    (append (noun-phrase)
            (verb-phrase))))

(define noun-phrase
  (λ ()
    (append (Article)
            (Noun))))

(define verb-phrase
  (λ ()
    (append (Verb)
            (noun-phrase))))

;; terminal symbols
(define Article (λ () (one-of '(the a))))
(define Noun (λ () (one-of '(man ball woman table))))
(define Verb (λ () (one-of '(hit took saw liked))))

;; ========================
;; 2-03-rule-based-solution
;; ========================

;; define parameters, global constants, *name* naming-convention in scheme

(define *simple-grammar*
  '((sentence -> (noun-phrase verb-phrase))
    (noun-phrase -> (Article Noun))
    (verb-phrase -> (Verb noun-phrase))
    (Article -> the a)
    (Noun -> man ball woman table)
    (Verb -> hit took saw liked))
  #|A grammar for a trivial subset of English.|#)

(define *grammar* *simple-grammar* #|The grammar used by
generate. Initially, this is *simple-grammar*, but we can
switch to other grammars.|#)

;; define a data abstraction layer for accessing rules
(define rule-lhs
  (λ (rule)
    "The left-hand side of a rule."
    (first rule)))

(define rule-rhs
  (λ (rule)
    "The right-hand side of a rule."
    (rest (rest rule))))

(define rewrites
  (λ (grammar category)
    "Return a list of the possible rewrites for this category."
    ;; (displayln "in rewrites")
    ;; (displayln "getting RHS of" category "from" grammar)
    ;; (displayln (assoc category grammar))
    (rule-rhs (assoc category grammar))))

;; write the generate procedure
(define generate
  (λ (grammar phrase)
    (cond
     [(pair? phrase)
      ;; If we get a list of things, as for a previously
      ;; rewritten expression, we apply generate to all
      ;; parts of the list and concattenate the result into
      ;; one list.
      (map-append (λ (part) (generate grammar part))
                  phrase)]
     [else
      ;; If we get a symbol, terminal or non-terminal, we
      ;; try to get its choices for substitution.
      (let ([choices (rewrites grammar phrase)])
        (cond
         [(null? choices)
          ;; If there are no choices, we are dealing with a
          ;; terminal symbol. If that is the case, we wrap
          ;; the symbol into a list to be able to append it
          ;; to other previous substitutions.
          (list phrase)]
         [else
          ;; If there are choices, we are dealing with a
          ;; non-terminal symbol. We make a choice by
          ;; choosing a random element.
          (generate grammar (random-element choices))]))])))

;; =========
;; EXERCISES
;; =========

;; EXERCISE 2.1

;; Write a version of generate that uses cond but avoids
;; calling rewrites twice.  Already done, see code above.

;; EXERCISE 2.2

;; Write a version of generate that explicitly
;; differentiates between terminal symbols (those with no
;; rewrite rules) and nonterminal symbols.

(define terminal?
  (λ (grammar phrase)
    (null? (rewrites grammar phrase))))

(define non-terminal?
  (λ (grammar phrase)
    (not terminal?)))

(define generate-explicit
  (λ (grammar phrase)
    "This generate procedure uses explicit predicates, but is
less performant, because the check for terminal symbol
requires looking the symbol up in the grammar, but does not
return the choices, if there are any and thus a second
lookup is potentially required later."
    (cond
     ;; could be a list of symbols
     [(pair? phrase)
      (map-append (λ (part) (generate-explicit grammar part))
                  phrase)]
     [(terminal? grammar phrase) (list phrase)]
     [else  ; non-terminal symbol
      (let ([choices (rewrites grammar phrase)])
        (generate-explicit grammar (random-element choices)))])))


;; Now we define a bigger grammar, to show, how the program
;; can be modified and extended, without changing the
;; generate procedure.
(define *bigger-grammar*
  '((sentence -> (noun-phrase verb-phrase))

    (noun-phrase -> (Article Adjective* Noun PersonalPronoun*) (Name) (Pronoun))
    (verb-phrase -> (Verb noun-phrase PersonalPronoun*))

    (PersonalPronoun* -> () (PersonalPronoun PersonalPronoun*))
    (PersonalPronoun -> (Prep noun-phrase))

    (Adjective* -> () (Adjective Adjective*))
    (Adjective -> big little blue green adiabatic)

    (Prep -> to in by with on)
    (Article -> the a)
    (Name -> Pat Kim Lee Terry Robin)
    (Noun -> man ball woman table)
    (Verb -> hit took saw liked)
    (Pronoun -> he she it these those that)))

;; We can recognize implicit rules of how to read this
;; grammar from looking at the generate procedure:

;; 1. () is the epsilon or empty symbol. Appended to an
;; unfinished (improper) list, it ends a list.

;; 2. When symbols are wrapped in parentheses, generate will
;; map itself to all symbols in the parentheses. This is
;; equivalent to saying, that a non-terminal symbol will be
;; substituted with multiple other symbols. Basically it is
;; AND, not an exclusive OR.

;; 3. When symbols are not wrapped in parentheses, one of
;; them is chosen. This is equivalent to making an exclusive
;; OR choice.

;; We can use this grammar right away with the generate
;; procedure.

;; Lets write a procedure, which takes the result of
;; generate and writes it as a string.

(define flatten-transform
  (λ (lst-or-atom transformation)
    "Flatten an arbitrarily nested list and map a transformation
recursively at the same time."
    (cond
     [(null? lst-or-atom) '()]
     [(pair? lst-or-atom)
      (append (flatten-transform (car lst-or-atom) transformation)
              (flatten-transform (cdr lst-or-atom) transformation))]
     [else
      (list (transformation lst-or-atom))])))


(define to-string
  (λ (parts)
    (with-output-to-string
      (λ ()
        (display
         (string-append
          (string-join (flatten-transform parts symbol->string) " ")
          "."))))))

;; And for convenience define a procedure to output a random
;; phrase.

(define display-sentence
  (λ ()
    (displayln
     (to-string
      (generate *bigger-grammar* 'sentence)))))


;; Next we write a procedure, which does not only give us
;; the terminal symbols, but also the non-terminal symbols,
;; which lead to the terminal symbols being chosen in a tree
;; structure. What sounds challenging at first becomes a
;; small modification of the generate procedure.

(define generate-tree
  (λ (grammar phrase)
    (cond
     [(pair? phrase)
      ;; instead of map-append, we use map (or mapcar in common lisp).
      (map (λ (part) (generate-tree grammar part))
           phrase)]
     [else
      (let ([choices (rewrites grammar phrase)])
        (cond
         [(null? choices)
          (list phrase)]
         [else
          ;; we cons the non-terminal to the non-terminal or
          ;; terminal that is produced from it, so that we
          ;; have it in the result.
          (cons phrase
                (generate-tree grammar (random-element choices)))]))])))

;; Next we write a procedure, which generates not only one
;; phrase from a given symbol, but all possible phrases.

(define no-expansion '())


(define combine-all
  (λ (xlist ylist)
    (map-append (λ (y)
                  (map (λ (x) (append x y))
                       xlist))
                ylist)))


(define generate-all
  (λ (grammar symb-or-lst)
    "Generate a list of all possible expansions of the given
symbol."
    (cond
     ;; In case we are given an empty list of symbols, we
     ;; return the list containing the empty expansion,
     ;; which is the empty list itself.
     [(null? symb-or-lst) (list no-expansion)]
     ;; In case we get a list of symbols to substitute for,
     ;; we combine all possibilities of substituting the
     ;; first symbol with all possibilities of substituting
     ;; the rest of the symbols. This is done using
     ;; recursive calls.
     [(pair? symb-or-lst)
      (combine-all (generate-all grammar (first symb-or-lst))
                   (generate-all grammar (cdr symb-or-lst)))]
     ;; Otherwise ...
     [else
      (let ([choices (rewrites grammar symb-or-lst)])
        (cond
         ;; ... if it is a terminal symbol, return a list of
         ;; the possible expansions, which are only one, the
         ;; terminal itself. Since it is a complete
         ;; expansion, we wrap it in a list.
         [(null? choices) (list (list symb-or-lst))]
         ;; If there are choices for expansions, generate
         ;; all expansions for the choices and return the
         ;; list of possible expansions.
         [else
          (map-append (λ (choice) (generate-all grammar choice))
                      choices)]))])))


;; Exercise 2.3

;; Write a trivial grammar for some other language. This can
;; be a natural language other than English, or perhaps a
;; subset of a computer language.

(define *chess-phrase-grammar*
  '((PHRASE ->
            NORMAL-PHRASE
            CHECK-PHRASE
            OFFER-DRAW-PHRASE
            CHECKMATE-PHRASE)
    (NORMAL-PHRASE -> (PIECE from FIELD to FIELD))
    (CHECK-PHRASE -> (PIECE from FIELD to FIELD check))
    (OFFER-DRAW-PHRASE -> (PIECE from FIELD to FIELD draw))
    (CHECKMATE-PHRASE -> (PIECE from FIELD to FIELD checkmate))
    (PIECE -> pawn knight bishop rook queen king)
    (FIELD ->
           a1 a2 a3 a4 a5 a6 a7 a8
           b1 b2 b3 b4 b5 b6 b7 b8
           c1 c2 c3 c4 c5 c6 c7 c8
           d1 d2 d3 d4 d5 d6 d7 d8
           e1 e2 e3 e4 e5 e6 e7 e8
           f1 f2 f3 f4 f5 f6 f7 f8
           g1 g2 g3 g4 g5 g6 g7 g8
           h1 h2 h3 h4 h5 h6 h7 h8)))

;; And try it out ...

;; (displayln
;;  (to-string
;;   (generate *chess-phrase-grammar* 'PHRASE)))

;; Exercise 2.4

;; One way of describing combine-all is that it calculates
;; the cross-product of the function append on the argument
;; lists. Write the higher-order function cross-product, and
;; define combine-all in terms of it.

;; The moral is to make your code as general as possible,
;; because you never know what you may want to do with it
;; next.

(define cross-product
  (λ (xlist ylist op)
    ;; Append all partial results into a long list.
    (map-append
     ;; Make a list by applying an operation to all elements
     ;; of ylist.
     (λ (y)
       ;; Apply the operation to all pairs of elements from
       ;; xlist and ylist.
       (map (λ (x) (op x y)) xlist))
     ylist)))


(define combine-all-2
  (λ (xlist ylist)
    (cross-product xlist
                   ylist
                   ;; This does not assume lists as inputs,
                   ;; like append does.
                   (λ (a b) (cons a (cons b '()))))))


(define generate-all-2
  (λ (grammar symb-or-lst)
    "Generate a list of all possible expansions of the given
symbol."
    (cond
     [(null? symb-or-lst) (list no-expansion)]
     [(pair? symb-or-lst)
      (combine-all (generate-all-2 grammar (first symb-or-lst))
                   (generate-all-2 grammar (cdr symb-or-lst)))]
     [else
      (let ([choices (rewrites grammar symb-or-lst)])
        (cond
         [(null? choices) (list (list symb-or-lst))]
         [else
          (map-append (λ (choice) (generate-all-2 grammar choice))
                      choices)]))])))