feat: 9.5.9

examples/freq.ss

@@ -0,0 +1,123 @@
+;;; freq.ss
+;;; Copyright (C) 1996 R. Kent Dybvig
+;;; from "The Scheme Programming Language, 2ed" by R. Kent Dybvig
+
+;;; Permission is hereby granted, free of charge, to any person obtaining a
+;;; copy of this software and associated documentation files (the "Software"),
+;;; to deal in the Software without restriction, including without limitation
+;;; the rights to use, copy, modify, merge, publish, distribute, sublicense,
+;;; and/or sell copies of the Software, and to permit persons to whom the
+;;; Software is furnished to do so, subject to the following conditions:
+;;; 
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;; 
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.  IN NO EVENT SHALL
+;;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE. 
+
+;;; If the next character on p is a letter, get-word reads a word
+;;; from p and returns it in a string.  If the character is not a
+;;; letter, get-word returns the character (on eof, the eof-object).
+(define get-word
+  (lambda (p)
+    (let ((c (read-char p)))
+      (if (eq? (char-type c) 'letter)
+          (list->string
+            (let loop ((c c))
+              (cons c
+                (if (memq (char-type (peek-char p)) '(letter digit))
+                    (loop (read-char p))
+                    '()))))
+          c))))
+
+;;; char-type tests for the eof-object first, since the eof-object
+;;; may not be a valid argument to char-alphabetic? or char-numeric?
+;;; It returns the eof-object, the symbol letter, the symbol digit,
+;;; or the argument itself if it is not a letter or digit.
+(define char-type
+  (lambda (c)
+    (cond
+      ((eof-object? c) c)
+      ((char-alphabetic? c) 'letter)
+      ((char-numeric? c) 'digit)
+      (else c))))
+
+;;; Trees are represented as vectors with four fields: word, left,
+;;; right, and count.  Only one field, word, is initialized by an
+;;; argument to the constructor procedure make-tree.  The remaining
+;;; fields are explicitly initialized and changed by subsequent
+;;; operations.  Most Scheme systems provide structure definition
+;;; facilities that automate creation of structure manipulation
+;;; procedures, but we simply define the procedures by hand here.
+(define make-tree
+  (lambda (word)
+    (vector word '() '() 1)))
+
+(define tree-word (lambda (tree) (vector-ref tree 0)))
+
+(define tree-left (lambda (tree) (vector-ref tree 1)))
+(define set-tree-left!
+  (lambda (tree new-left)
+    (vector-set! tree 1 new-left)))
+
+(define tree-right (lambda (tree) (vector-ref tree 2)))
+(define set-tree-right!
+  (lambda (tree new-right)
+    (vector-set! tree 2 new-right)))
+
+(define tree-count (lambda (tree) (vector-ref tree 3)))
+(define set-tree-count!
+  (lambda (tree new-count)
+    (vector-set! tree 3 new-count)))
+
+;;; If the word already exists in the tree, tree increments its
+;;; count.  Otherwise, a new tree node is created and put into the
+;;; tree.  In any case, the new or modified tree is returned.
+(define tree
+  (lambda (node word)
+    (cond
+      ((null? node) (make-tree word))
+      ((string=? word (tree-word node))
+       (set-tree-count! node (+ (tree-count node) 1))
+       node)
+      ((string<? word (tree-word node))
+       (set-tree-left! node (tree (tree-left node) word))
+       node)
+      (else
+       (set-tree-right! node (tree (tree-right node) word))
+       node))))
+
+;;; tree-print prints the tree in "in-order," i.e., left subtree,
+;;; then node, then right subtree.  For each word, the count and the
+;;; word are printed on a single line.
+(define tree-print
+  (lambda (node p)
+    (if (not (null? node))
+        (begin
+          (tree-print (tree-left node) p)
+          (write (tree-count node) p)
+          (write-char #\space p)
+          (display (tree-word node) p)
+          (newline p)
+          (tree-print (tree-right node) p)))))
+
+;;; frequency is the driver routine.  It opens the files, reads the
+;;; words, and enters them into the tree.  When the input port
+;;; reaches end-of-file, it prints the tree and closes the ports.
+(define frequency
+  (lambda (infn outfn)
+    (let ((ip (open-input-file infn))
+          (op (open-output-file outfn)))
+      (let loop ((root '()))
+        (let ((w (get-word ip)))
+          (cond
+             ((eof-object? w) (tree-print root op))
+             ((string? w) (loop (tree root w)))
+             (else (loop root)))))
+       (close-input-port ip)
+       (close-output-port op))))