From 21c3d4b46fdc924bb0e35be2be3e0d5d061d3c42 Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson@vistahigherlearning.com>
Date: Wed, 17 Mar 2021 09:45:37 -0400
Subject: chapter-2: Add start of regular expressions section.

---
 chapter-2/2.2-regular-expressions.scm | 154 ++++++++++++++++++++++++++++++++++
 1 file changed, 154 insertions(+)
 create mode 100644 chapter-2/2.2-regular-expressions.scm

(limited to 'chapter-2/2.2-regular-expressions.scm')

diff --git a/chapter-2/2.2-regular-expressions.scm b/chapter-2/2.2-regular-expressions.scm
new file mode 100644
index 0000000..fa92120
--- /dev/null
+++ b/chapter-2/2.2-regular-expressions.scm
@@ -0,0 +1,154 @@
+;;; Copyright © 2021 Gerald Sussman and Chris Hanson
+;;; Copyright © 2021 David Thompson <dthompson2@worcester.edu>
+;;;
+;;; This program is free software: you can redistribute it and/or
+;;; modify it under the terms of the GNU General Public License as
+;;; published by the Free Software Foundation, either version 3 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program.  If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(use-modules (ice-9 popen)
+             (srfi srfi-1))
+
+
+;; 2.2.2 Implementation of the translator
+
+(define-syntax-rule (assert cond)
+  (unless cond
+    (error "assertion failed" 'cond)))
+
+;; I am excluding the write-bourne-shell-grep-command and
+;; bourne-shell-command-string procedures in the book in favor of
+;; using Guile's pipe API. open-pipe* does not open a shell but runs
+;; grep directly, eliminating the need to do shell quoting.  The book
+;; asks "Are we having fun yet?" to which I say "yes, but I draw the
+;; line at shell quoting."
+(define (grep regexp string)
+  (let ((pipe (open-pipe* OPEN_WRITE "grep" "-e" regexp)))
+    (display string pipe)
+    (newline pipe)
+    (zero? (status:exit-val (close-pipe pipe)))))
+
+(define (grep-test regexp . specs)
+  (for-each (lambda (spec)
+              (assert
+               (if (and (pair? spec) (eq? (car spec) 'not))
+                   (not (grep regexp (list-ref spec 1)))
+                   (grep regexp spec))))
+            specs))
+
+(define (r:dot) ".")
+(define (r:bol) "^")
+(define (r:eol) "$")
+
+(define (r:seq . exprs)
+  (string-append "\\(" (apply string-append exprs) "\\)"))
+
+(define chars-needing-quoting
+  '(#\. #\[ #\\ #\^ #\$ #\*))
+
+(define (r:quote string)
+  (r:seq
+   (list->string
+    (append-map (lambda (char)
+                  (if (memv char chars-needing-quoting)
+                      (list #\\ char)
+                      (list char)))
+                (string->list string)))))
+
+(grep-test (r:seq (r:quote "a") (r:dot) (r:quote "c"))
+           "abc")
+
+(define (r:alt . exprs)
+  (if (pair? exprs)
+      (apply r:seq
+             (cons (car exprs)
+                   (append-map (lambda (expr)
+                                 (list "\\|" expr))
+                               (cdr exprs))))
+      (r:seq)))
+
+(grep-test (r:alt (r:quote "foo") (r:quote "bar") (r:quote "baz"))
+           "foo" "bar" "baz" '(not "frob"))
+
+(define (r:repeat min max expr)
+  (apply r:seq
+         (append (make-list min expr)
+                 (cond
+                  ((not max)
+                   (list expr "*"))
+                  ((= max min)
+                   '())
+                  (else
+                   (make-list (- max min) (r:alt expr "")))))))
+
+(grep-test (r:repeat 3 5 (r:alt (r:quote "cat") (r:quote "dog")))
+           "catdogcat"
+           "catcatdogdog"
+           "dogdogcatdogdog"
+           '(not "catdogfrog"))
+
+(define (bracket string procedure)
+  (list->string
+   (append '(#\[)
+           (procedure (string->list string))
+           '(#\]))))
+
+(define chars-needing-quoting-in-brackets
+  '(#\] #\^ #\-))
+
+(define (quote-bracketed-contents members)
+  (define (optional char)
+    (if (memv char members)
+        (list char)
+        '()))
+  (append (optional #\])
+          (remove (lambda (c)
+                    (memv c chars-needing-quoting-in-brackets))
+                  members)
+          (optional #\^)
+          (optional #\-)))
+
+(define (r:char-from string)
+  (case (string-length string)
+    ((0) (r:seq))
+    ((1) (r:quote string))
+    (else
+     (bracket string
+              (lambda (members)
+                (if (lset= eq? '(#\- #\^) members)
+                    '(#\- #\^)
+                    (quote-bracketed-contents members)))))))
+
+(define (r:char-not-from string)
+  (bracket string
+           (lambda (members)
+             (cons #\^ (quote-bracketed-contents members)))))
+
+
+;; Exercise 2.6: Adding * and + to regular expressions
+
+(define (r:* expr)
+  (r:repeat 0 #f expr))
+
+(define (r:+ expr)
+  (r:repeat 1 #f expr))
+
+(grep-test (r:* (r:quote "foo"))
+           "" "foo" "bar")
+(grep-test (r:seq (r:quote "foo") (r:* (r:quote "bar")))
+           "foo" "foobar" '(not ""))
+(grep-test (r:+ (r:quote "foo"))
+           '(not "") "foo" "foofoo")
+(grep-test (r:seq (r:quote "foo") (r:+ (r:quote "bar")))
+           '(not "foo") "foobar" "foobarbar")
+
+;; Exercise 2.7: A bug, one bad joke, two tweaks, and a revelation
-- 
cgit v1.2.3