diff options
| -rw-r--r-- | ps02_generics/generic-sequences.scm | 114 | ||||
| -rw-r--r-- | ps02_generics/generic-specs.scm | 121 | ||||
| -rw-r--r-- | ps02_generics/ghelper.scm | 84 | ||||
| -rw-r--r-- | ps02_generics/ps.txt | 593 |
4 files changed, 912 insertions, 0 deletions
diff --git a/ps02_generics/generic-sequences.scm b/ps02_generics/generic-sequences.scm new file mode 100644 index 0000000..5e426cf --- /dev/null +++ b/ps02_generics/generic-sequences.scm @@ -0,0 +1,114 @@ +;;;; Generic sequence operator definitions + +;;; First we declare the operators we want to be generic. +;;; Each declaration specifies the arity (number of arguments) +;;; and the default operation, if necessary. + +(define sequence:null + (make-generic-operator 1 #f)) + + +(define sequence:ref + (make-generic-operator 2 #f)) + +(define sequence:size + (make-generic-operator 1 #f)) + +(define sequence:type + (make-generic-operator 1 #f)) + +(define sequence:null? + (make-generic-operator 1 #f)) + +(define sequence:equal? + (make-generic-operator 2 #f)) + +(define sequence:set! + (make-generic-operator 3 #f)) + +(define sequence:subsequence + (make-generic-operator 3 #f)) + + +;;; sequence:append takes multiple arguments. It is defined in terms +;;; of a binary generic append that takes a sequence and a list of sequences. + +(define (sequence:append . sequences) + (if (null? sequences) + (error "Need at least one sequence for append")) + (let ((type? (sequence:type (car sequences)))) + (if (not (for-all? (cdr sequences) type?)) + (error "All sequences for append must be of the same type" + sequences)) + (fold-right generic:binary-append + (sequence:null (sequence:type (car sequences))) + sequences))) + +(define generic:binary-append (make-generic-operator 2 #f)) + +;;; Implementations of the generic operators. + +(define (any? x) #t) +(define (constant val) (lambda (x) val)) +(define (is-exactly val) (lambda (x) (eq? x val))) + +(assign-operation sequence:null (constant "") (is-exactly string?)) +(assign-operation sequence:null (constant '()) (is-exactly list?)) +(assign-operation sequence:null (constant #()) (is-exactly vector?)) + +(assign-operation sequence:ref string-ref string? exact-integer?) +(assign-operation sequence:ref list-ref list? exact-integer?) +(assign-operation sequence:ref vector-ref vector? exact-integer?) + +(assign-operation sequence:size string-length string?) +(assign-operation sequence:size length list?) +(assign-operation sequence:size vector-length vector?) + +(assign-operation sequence:type (constant string?) string?) +(assign-operation sequence:type (constant list?) list?) +(assign-operation sequence:type (constant vector?) vector?) + + +(define (vector-null? v) (= (vector-length v) 0)) + +(assign-operation sequence:null? string-null? string?) +(assign-operation sequence:null? null? list?) +(assign-operation sequence:null? vector-null? vector?) + + +;;; To assign to the ith element of a list: + +(define (list-set! list i val) + (cond ((null? list) + (error "List does not have enough elements" i)) + ((= i 0) (set-car! list val)) + (else (list-set! (cdr list) (- i 1) val)))) + +(assign-operation sequence:set! string-set! string? exact-integer? any?) +(assign-operation sequence:set! list-set! list? exact-integer? any?) +(assign-operation sequence:set! vector-set! vector? exact-integer? any?) + + +(assign-operation sequence:subsequence + substring + string? exact-integer? exact-integer?) +(assign-operation sequence:subsequence + sublist + list? exact-integer? exact-integer?) +(assign-operation sequence:subsequence + subvector + vector? exact-integer? exact-integer?) + + +(define (vector-append v1 v2) + (let ((n1 (vector-length v1)) + (n2 (vector-length v2))) + (make-initialized-vector (+ n1 n2) + (lambda (i) + (if (< i n1) + (vector-ref v1 i) + (vector-ref v2 (- i n1))))))) + +(assign-operation generic:binary-append string-append string? string?) +(assign-operation generic:binary-append append list? list?) +(assign-operation generic:binary-append vector-append vector? vector?) diff --git a/ps02_generics/generic-specs.scm b/ps02_generics/generic-specs.scm new file mode 100644 index 0000000..ad07d96 --- /dev/null +++ b/ps02_generics/generic-specs.scm @@ -0,0 +1,121 @@ +;;;; Generic sequence operations + +;;; There are many kinds of data that can be used to represent sequences: +;;; examples include strings, lists, and vectors. + +;;; There are operations that can be defined for all sequence types. + +;;; Constructing +;;; +;;; (sequence:construct <sequence-type> <item-1> ... <item-n>) +;;; Constructs a new sequence of the given type and of size n with +;;; the given elements: item-1 ... item-n + +;;; (sequence:null <sequence-type>) +;;; Produces the null sequence of the given type + + +;;; Selecting +;;; +;;; (sequence:ref <sequence> <i>) +;;; Returns the ith element of the sequence. We use zero-based +;;; indexing, so for a sequence of length n the ith item is +;;; referenced by (sequence:ref <sequence> <i-1>). + +;;; (sequence:size <sequence>) +;;; Returns the number of elements in the sequence. + +;;; (sequence:type <sequence>) +;;; Returns the predicate defining the type of the sequence given. + + +;;; Testing +;;; +;;; (sequence:null? <sequence>) +;;; Returns #t if the sequence is null, otherwise returns #f. + +;;; (sequence:equal? <sequence-1> <sequence-2>) +;;; Returns #t if the sequences are of the same type and have equal +;;; elements in the same order, otherwise returns #f. + + +;;; Mutation +;;; +;;; Some sequences are immutable, while others can be changed. +;;; +;;; For those that can be modified we can change an element: +;;; +;;; (sequence:set! <sequence> <i> <v>) +;;; Sets the ith element of the sequence to v. + +;;; Cutting and Pasting +;;; +;;; (sequence:subsequence <sequence> <start> <end>) +;;; The arguments start and end must be exact integers such that +;;; 0 <= start <= end <= (sequence:size <sequence>). +;;; Returns a new sequence of the same type as the given sequence, +;;; of size end-start with elements selected from the given sequence. +;;; The new sequence starts with the element of the given sequence +;;; referenced by start. It ends with the element of the given +;;; sequence referenced by end-1. + +;;; (sequence:append <sequence-1> ... <sequence-n>) +;;; Requires that the sequences are all of the same type. Returns +;;; a new sequence of the type, formed by concatenating the +;;; elements of the given sequences. The size of the new sequence +;;; is the sum of the sizes of the given sequences. + +;;; Iterators +;;; +;;; (sequence:generate <sequence-type> <n> <function>) +;;; Makes a new sequence of the given sequence type, of size n. +;;; The ith element of the new sequence is the value of the +;;; function at the index i. + +;;; (sequence:map <function> <seq-1> ... <seq-n>) +;;; Requires that the sequences given are of the same size and +;;; type, and that the arity of the function is n. The ith element +;;; of the new sequence is the value of the function applied to the +;;; n ith elements of the given sequences. + +;;; (sequence:for-each <procedure> <seq-1> ... <seq-n>) +;;; Requires that the sequences given are of the same size and +;;; type, and that the arity of the procedure is n. Applies the +;;; procedure to the n ith elements of the given sequences; +;;; discards the value. This is done for effect. + +;;; Filtration and Search +;;; +;;; (sequence:filter <sequence> <predicate>) +;;; Returns a new sequence with exactly those elements of the given +;;; sequence for which the predicate is true (does not return #f). +;;; +;;; (sequence:get-index <sequence> <predicate>) +;;; Returns the index of the first element of the sequence that +;;; satisfies the predicate. Returns #f if no element of the +;;; sequence satisfies the predicate. +;;; +;;; (sequence:get-element <sequence> <predicate>) +;;; Returns the first element of the sequence that satisfies the +;;; predicate. Returns #f if no element of the sequence satisfies +;;; the predicate. + +;;; Accumulation +;;; +;;; (sequence:fold-right <function> <initial> <sequence>) +;;; Returns the result of applying the given binary function, +;;; from the right, starting with the initial value. +;;; For example, +;;; (sequence:fold-right list 'end '(a b c)) +;;; => (a (b (c end))) + +;;; +;;; (sequence:fold-left <function> <initial> <sequence>) +;;; Returns the result of applying the given binary function, +;;; starting with the initial value, from the left. +;;; For example, +;;; (sequence:fold-left list 'start '(a b c)) +;;; => (((start a) b) c) + + + diff --git a/ps02_generics/ghelper.scm b/ps02_generics/ghelper.scm new file mode 100644 index 0000000..c6a7f85 --- /dev/null +++ b/ps02_generics/ghelper.scm @@ -0,0 +1,84 @@ +;;;; Most General Generic-Operator Dispatch + +(declare (usual-integrations)) + +;;; Generic-operator dispatch is implemented here by a discrimination +;;; list, where the arguments passed to the operator are examined by +;;; predicates that are supplied at the point of attachment of a +;;; handler (by ASSIGN-OPERATION). + +;;; To be the correct branch all arguments must be accepted by +;;; the branch predicates, so this makes it necessary to +;;; backtrack to find another branch where the first argument +;;; is accepted if the second argument is rejected. Here +;;; backtracking is implemented by OR. + +(define (make-generic-operator arity default-operation) + (let ((record (make-operator-record arity))) + + (define (operator . arguments) + (if (not (= (length arguments) arity)) + (error:wrong-number-of-arguments operator arity arguments)) + (apply (or (let per-arg + ((tree (operator-record-tree record)) + (args arguments)) + (let per-pred ((tree tree)) + (and (pair? tree) + (if ((caar tree) (car args)) + (if (pair? (cdr args)) + (or (per-arg (cdar tree) (cdr args)) + (per-pred (cdr tree))) + (cdar tree)) + (per-pred (cdr tree)))))) + default-operation + (error:no-applicable-methods operator arguments)) + arguments)) + + (hash-table/put! *generic-operator-table* operator record) + operator)) + +(define *generic-operator-table* + (make-eq-hash-table)) + +(define (make-operator-record arity) (cons arity '())) +(define (operator-record-arity record) (car record)) +(define (operator-record-tree record) (cdr record)) +(define (set-operator-record-tree! record tree) (set-cdr! record tree)) + +(define (assign-operation operator handler . argument-predicates) + (let ((record + (let ((record (hash-table/get *generic-operator-table* operator #f)) + (arity (length argument-predicates))) + (if record + (begin + (if (not (= arity (operator-record-arity record))) + (error "Incorrect operator arity:" operator)) + record) + (let ((record (make-operator-record arity))) + (hash-table/put! *generic-operator-table* operator record) + record))))) + (set-operator-record-tree! record + (bind-in-tree argument-predicates + handler + (operator-record-tree record)))) + operator) + +(define (bind-in-tree keys handler tree) + (let loop ((keys keys) (tree tree)) + (let ((p.v (assq (car keys) tree))) + (if (pair? (cdr keys)) + (if p.v + (begin + (set-cdr! p.v + (loop (cdr keys) (cdr p.v))) + tree) + (cons (cons (car keys) + (loop (cdr keys) '())) + tree)) + (if p.v + (begin + (warn "Replacing a handler:" (cdr p.v) handler) + (set-cdr! p.v handler) + tree) + (cons (cons (car keys) handler) + tree)))))) diff --git a/ps02_generics/ps.txt b/ps02_generics/ps.txt new file mode 100644 index 0000000..82dfa2a --- /dev/null +++ b/ps02_generics/ps.txt @@ -0,0 +1,593 @@ + + MASSACHVSETTS INSTITVTE OF TECHNOLOGY + Department of Electrical Engineering and Computer Science + + 6.945 Spring 2009 + Problem Set 2 + + Issued: Wed. 11 Feb. 2009 Due: Wed. 18 Feb. 2009 + +Reading: + SICP sections 2.4 and 2.5 + (Tagged data, Data-directed programming, Generic Operations) + + If you are really interested in generic dispatch see the paper + by Ernst, et al. Do not obsess over the formal semantics, what + is really interesting here is the way predicate dispatch can be + used to subsume other kinds of dispatch. +http://pag.csail.mit.edu/~mernst/pubs/dispatching-ecoop98-abstract.html + +Code: ghelper.scm, generic-specs.scm, generic-sequences.scm, attached. + +Documentation: + The MIT/GNU Scheme documentation + online at http://www.gnu.org/software/mit-scheme/ + + + Generic Operations + +In this problem set we will explore a variety of methods we can use for +implementing and exploiting generic operations. + +The procedures in the file ghelper.scm are an elegant mechanism for +implementing generic-operator dispatch, where the handlers for the +generic operators are specified by the predicates that the arguments +satisfy. + +The file generic-specs.scm is an informal programmer's specification +of generic operations that can be defined over a variety of ordered +linear data structures, such as lists, vectors, and strings. + +The file, generic-sequences.scm is a beginning implementation of the +generic operators specified in generic-specs.scm. + +------------- +Problem 2.1: + +Complete the implementation started in generic-sequences.scm to match +the specifications in generic-specs.scm. Demonstrate that each of +your generic operators works as specified, by showing examples. You +should insert your tests as comments in the code you hand in. + +Notice that the types in the underlying Scheme are not uniformly +specified, so this is not entirely trivial: in our seed file, for +example, we had to define vector-null?, list-set!, and vector-append +just to fill out things a bit. +------------- + +Operations like sequence:append can be extended to allow the +combination of unlike sequences. For example, we might expect to be +able to write + + (sequence:append (list 'a 'b 'c) (vector 'd 'e 'f)) + +and get back the list (a b c d e f), assuming that we want a sequence +of the first argument type to be the sequence type of the result. + +One way to implement this sort of thing is to write specific handlers +for all the combinations of types we might want. This may be a large +problem. However, the problem can be mitigated by using coercions, +such as vector->list, list->vector, etc. The cost of doing the +coercions is the construction of a new intermediate data structure +that is not needed in the result. This may or may not be important, +depending on the application. With coercions, we make up and use new +combinators to help construct the generic operator entries: + + (define (compose-1st-arg f g) + (lambda (x y) (f (g x) y))) + + (define (compose-2nd-arg f g) + (lambda (x y) (f x (g y)))) + +Using these we can write such things as: + + (assign-operation generic:binary-append + (compose-2nd-arg vector-append list->vector) + vector? list?) + + (assign-operation generic:binary-append + (compose-2nd-arg append vector->list) + list? vector?) + + +------------- +Problem 2.2: + +Examine the generic specifications. What generalizations that mix +combinations of sequence types may be useful? Amend the specification +document so as to include the generalization. (Turn in the amended +specification sheet with your changes clearly indicated.) Amend your +implementation to make these generalizations. + +Some of the coercions that you may need are provided by Scheme, but +others may need to be written, such as vector->string. (Consult the +online MIT/GNU Scheme reference manual to see what is and is not +provided.) +------------- + +The code for sequence:append illustrates an interesting problem. Our +generic dispatch program does not allow us to make generic operations +with unspecified arity -- that take many arguments -- such as +addition. We programmed around that restriction by defining a binary +generic operation and then using a folding reduction (fold-right) to +extend the binary operation to take an arbitrary number of arguments. +However, the folding reduction needs to know the null sequence of the +type being constructed. Alternatively, we could have extended the +generic dispatch to allow creation of procedures with unspecified +arity. This would allow us to move the folding to the type-specific +procedures rather than make it a wrapper around the binary generic +procedure. + + +------------- +Problem 2.3 + +Is this a good idea? (Please state and argue your opinion.) + +Assuming that we want to do this, what changes would you have to make +in the ghelper.scm file? For example, how would make-generic-operator +have to change? assign-operation? + +We do not want you to actually implement these changes, just think +about what would have to be done and informally describe your +conclusions. +------------- + + +Ben Bitdiddle is pleased with our generic sequences but notes that, +beyond generic N-tuples, it is useful also to have generic sets. He +proposes that we further extend our language with: + + (generic:sequence->set <sequence>) + Returns a list corresponding to <sequence> with no duplicates. + Duplication is determined using EQUAL? (not EQ? nor EQV?). + + The remaining traditional set operations are straightforward: + + (set:equal? <set-1> <set-2>) + (set:union <set-1> <set-2>) + (set:intersection <set-1> <set-2>) + (set:difference <set-1> <set-2>) - E.g. {A,B,C}\{9,B,D}={A,C} + (set:strict-subset? <set-1> <set-2>) + +Alyssa P. Hacker is quick to point out that an efficient way to +implement sets is as sorted, irredundant lists. She adds, ``Of +course, this would require a generic:less? predicate to induce a total +order on the potential set elements.'' + +To that end, Alyssa proposes the following ordering on types of objects: + + null < Boolean < char < number < symbol < string < vector < list + +She notes that MIT Scheme already provides handy implementations of +each of: char<?, <, symbol<? and string<?. Adding that null<? and +boolean<? are straightforward to define and that vector<? can just +cheat and resort to list<? (for now), she cautions that list<?, on the +other hand, must take special care to ensure that: + + (generic:less? x y) + implies (not (generic:less? y x)) + +...in order to be well defined (and, thus, well behaved), although +list<? can, of course, leverage generic:less? in any recursive +subexpression predications. + +Louis Reasoner, ignoring this advice, proposes the following +implementation of list<?: + +(define (list<? list-1 list-2) + (let ((len-1 (length list-1)) + (len-2 (length list-2))) + (cond ((< len-1 len-2) #t) + ((> len-1 len-2) #f) + ;; Invariant: equal lengths + ((null? list-1) #f) ; same + (else + (or (generic:less? (car list-1) (car list-2)) + (generic:less? (cdr list-1) (cdr list-2))))))) + +Alyssa counters that the following is more appropriate: + +(define (list<? list-1 list-2) + (let ((len-1 (length list-1)) + (len-2 (length list-2))) + (cond ((< len-1 len-2) #t) + ((> len-1 len-2) #f) + ;; Invariant: equal lengths + (else + (let prefix<? ((list-1 list-1) + (list-2 list-2)) + (cond ((null? list-1) #f) ; same + ((generic:less? (car list-1) (car list-2)) #t) + ((generic:less? (car list-2) (car list-1)) #f) + (else (prefix<? (cdr list-1) (cdr list-2))))))))) + +As a parting shot, Alyssa also advises that entering N^2 items into the +generic dispatch table can be avoided by just defining generic:less? +outright, as per: + +(define (generic:less? x y) + (cond ((null? x) (if (null? y) (null<? x y) #t)) + ((null? y) #f) + ((boolean? x) (if (boolean? y) (boolean<? x y) #t)) + ((boolean? y) #f) + ... + (else (error "Unrecognized data type" x)))) + +------------- +Problem 2.4: + +A. What's wrong with Louis' implementation of the list<? predicate? + Give a simple example and a brief explanation of what problems + this would cause if it were used in generic:less? to sort sets. + +B. Briefly critique Alyssa's suggesting for implementing generic:less? + as an explicit case analysis versus using the dispatch table. + +C. Implement and demonstrate Ben's specification for set operations + using Alyssa's total ordering of data types (and her list<? code). + (Feel free to use MIT Scheme's native SORT procedure.) + +D. Critique how your implementation would change had we not taken + Alyssa's recommendation of implementing sets as sorted lists. + Consider both the code size as well as its run-time complexity. +------------- + + +The system for implementing generic operations that we have looked at +so far in this problem set is extremely general and flexible: the +dispatch to a handler is based on arbitrary predicates applied to +the arguments. Most generic operation systems are more constrained, +in that the arguments are presumed to have types that are determined +either statically by some declaration mechanism or by a type tag that +is associated with the argument data. For example, in the SICP +readings for this problem set, the data is tagged and the dispatch is +based on these tags. Such a tagged-data system has important +advantages of efficiency, but it gives up some flexibility. + + +------------- +Problem 2.5: + +How much does dispatch on predicates cost? What is the fundamental +efficiency problem here? Imagine that we have a system with tagged +data, but that we test for the tags with predicates. What can be done +with the data tags that can eliminate much of the work of the +predicate-based system? + +On the other hand, what do we give up in a more conventional system, +such as the one outlined in SICP, by contrast to the predicate-based +system? What is an example of lost flexibility? + +Write a few clear paragraphs expounding on these ideas. Try to +separate accident from essence. (Some aspects of a system are +consequences of accidental choices--ones that could easily be +changed--such as the use of a hash table rather than an association +list. Other aspects are essential in that no local modifications can +significantly change the behavior.) +------------- + +;;;; Generic sequence operations +;;; generic-specs.scm + +;;; There are many kinds of data that can be used to represent sequences: +;;; examples include strings, lists, and vectors. + +;;; There are operations that can be defined for all sequence types. + +;;; Constructing +;;; +;;; (sequence:construct <sequence-type> <item-1> ... <item-n>) +;;; Constructs a new sequence of the given type and of size n with +;;; the given elements: item-1 ... item-n + +;;; (sequence:null <sequence-type>) +;;; Produces the null sequence of the given type + + +;;; Selecting +;;; +;;; (sequence:ref <sequence> <i>) +;;; Returns the ith element of the sequence. We use zero-based +;;; indexing, so for a sequence of length n the ith item is +;;; referenced by (sequence:ref <sequence> <i-1>). + +;;; (sequence:size <sequence>) +;;; Returns the number of elements in the sequence. + +;;; (sequence:type <sequence>) +;;; Returns the predicate defining the type of the sequence given. + + +;;; Testing +;;; +;;; (sequence:null? <sequence>) +;;; Returns #t if the sequence is null, otherwise returns #f. + +;;; (sequence:equal? <sequence-1> <sequence-2>) +;;; Returns #t if the sequences are of the same type and have equal +;;; elements in the same order, otherwise returns #f. + + +;;; Mutation +;;; +;;; Some sequences are immutable, while others can be changed. +;;; +;;; For those that can be modified we can change an element: +;;; +;;; (sequence:set! <sequence> <i> <v>) +;;; Sets the ith element of the sequence to v. + +;;; Cutting and Pasting +;;; +;;; (sequence:subsequence <sequence> <start> <end>) +;;; The arguments start and end must be exact integers such that +;;; 0 <= start <= end <= (sequence:size <sequence>). +;;; Returns a new sequence of the same type as the given sequence, +;;; of size end-start with elements selected from the given sequence. +;;; The new sequence starts with the element of the given sequence +;;; referenced by start. It ends with the element of the given +;;; sequence referenced by end-1. + +;;; (sequence:append <sequence-1> ... <sequence-n>) +;;; Requires that the sequences are all of the same type. Returns +;;; a new sequence of the type, formed by concatenating the +;;; elements of the given sequences. The size of the new sequence +;;; is the sum of the sizes of the given sequences. + +;;; Iterators +;;; +;;; (sequence:generate <sequence-type> <n> <function>) +;;; Makes a new sequence of the given sequence type, of size n. +;;; The ith element of the new sequence is the value of the +;;; function at the index i. + +;;; (sequence:map <function> <seq-1> ... <seq-n>) +;;; Requires that the sequences given are of the same size and +;;; type, and that the arity of the function is n. The ith element +;;; of the new sequence is the value of the function applied to the +;;; n ith elements of the given sequences. + +;;; (sequence:for-each <procedure> <seq-1> ... <seq-n>) +;;; Requires that the sequences given are of the same size and +;;; type, and that the arity of the procedure is n. Applies the +;;; procedure to the n ith elements of the given sequences; +;;; discards the value. This is done for effect. + +;;; Filtration and Search +;;; +;;; (sequence:filter <sequence> <predicate>) +;;; Returns a new sequence with exactly those elements of the given +;;; sequence for which the predicate is true (does not return #f). +;;; +;;; (sequence:get-index <sequence> <predicate>) +;;; Returns the index of the first element of the sequence that +;;; satisfies the predicate. Returns #f if no element of the +;;; sequence satisfies the predicate. +;;; +;;; (sequence:get-element <sequence> <predicate>) +;;; Returns the first element of the sequence that satisfies the +;;; predicate. Returns #f if no element of the sequence satisfies +;;; the predicate. + +;;; Accumulation +;;; +;;; (sequence:fold-right <function> <initial> <sequence>) +;;; Returns the result of applying the given binary function, +;;; from the right, starting with the initial value. +;;; For example, +;;; (sequence:fold-right list 'end '(a b c)) +;;; => (a (b (c end))) + +;;; +;;; (sequence:fold-left <function> <initial> <sequence>) +;;; Returns the result of applying the given binary function, +;;; starting with the initial value, from the left. +;;; For example, +;;; (sequence:fold-left list 'start '(a b c)) +;;; => (((start a) b) c) + +;;;; Generic sequence operator definitions +;;; generic-sequences.scm + +;;; First we declare the operators we want to be generic. +;;; Each declaration specifies the arity (number of arguments) +;;; and the default operation, if necessary. + +(define sequence:null + (make-generic-operator 1 #f)) + + +(define sequence:ref + (make-generic-operator 2 #f)) + +(define sequence:size + (make-generic-operator 1 #f)) + +(define sequence:type + (make-generic-operator 1 #f)) + +(define sequence:null? + (make-generic-operator 1 #f)) + +(define sequence:equal? + (make-generic-operator 2 #f)) + +(define sequence:set! + (make-generic-operator 3 #f)) + +(define sequence:subsequence + (make-generic-operator 3 #f)) + + +;;; sequence:append takes multiple arguments. It is defined in terms +;;; of a binary generic append that takes a sequence and a list of +;;; sequences. + +(define (sequence:append . sequences) + (if (null? sequences) + (error "Need at least one sequence for append")) + (let ((type? (sequence:type (car sequences)))) + (if (not (for-all? (cdr sequences) type?)) + (error "All sequences for append must be of the same type" + sequences)) + (fold-right generic:binary-append (sequence:null type?) sequences))) + +(define generic:binary-append (make-generic-operator 2 #f)) + +;;; Implementations of the generic operators. + +(define (any? x) #t) +(define (constant val) (lambda (x) val)) +(define (is-exactly val) (lambda (x) (eq? x val))) + +(assign-operation sequence:null (constant "") (is-exactly string?)) +(assign-operation sequence:null (constant '()) (is-exactly list?)) +(assign-operation sequence:null (constant #()) (is-exactly vector?)) + +(assign-operation sequence:ref string-ref string? exact-nonnegative-integer?) +(assign-operation sequence:ref list-ref list? exact-nonnegative-integer?) +(assign-operation sequence:ref vector-ref vector? exact-nonnegative-integer?) + +(assign-operation sequence:size string-length string?) +(assign-operation sequence:size length list?) +(assign-operation sequence:size vector-length vector?) + +(assign-operation sequence:type (constant string?) string?) +(assign-operation sequence:type (constant list?) list?) +(assign-operation sequence:type (constant vector?) vector?) + + +(define (vector-null? v) (= (vector-length v) 0)) + +(assign-operation sequence:null? string-null? string?) +(assign-operation sequence:null? null? list?) +(assign-operation sequence:null? vector-null? vector?) + + +;;; To assign to the ith element of a list: + +(define (list-set! list i val) + (cond ((null? list) + (error "List does not have enough elements" i)) + ((= i 0) (set-car! list val)) + (else (list-set! (cdr list) (- i 1) val)))) + +(assign-operation sequence:set! string-set! + string? exact-nonnegative-integer? any?) +(assign-operation sequence:set! list-set! + list? exact-nonnegative-integer? any?) +(assign-operation sequence:set! vector-set! + vector? exact-nonnegative-integer? any?) + +(assign-operation sequence:subsequence substring + string? exact-nonnegative-integer? exact-nonnegative-integer?) + +(assign-operation sequence:subsequence sublist + list? exact-nonnegative-integer? exact-nonnegative-integer?) + +(assign-operation sequence:subsequence subvector + vector? exact-nonnegative-integer? exact-nonnegative-integer?) + + +(define (vector-append v1 v2) + (let ((n1 (vector-length v1)) + (n2 (vector-length v2))) + (make-initialized-vector (+ n1 n2) + (lambda (i) + (if (< i n1) + (vector-ref v1 i) + (vector-ref v2 (- i n1))))))) + +(assign-operation generic:binary-append string-append string? string?) +(assign-operation generic:binary-append append list? list?) +(assign-operation generic:binary-append vector-append vector? vector?) + +;;;; Most General Generic-Operator Dispatch +;;; ghelper.scm + +(declare (usual-integrations)) + +;;; Generic-operator dispatch is implemented here by a discrimination +;;; list, where the arguments passed to the operator are examined by +;;; predicates that are supplied at the point of attachment of a +;;; handler (by ASSIGN-OPERATION). + +;;; To be the correct branch all arguments must be accepted by +;;; the branch predicates, so this makes it necessary to +;;; backtrack to find another branch where the first argument +;;; is accepted if the second argument is rejected. Here +;;; backtracking is implemented by OR. + +(define (make-generic-operator arity default-operation) + (let ((record (make-operator-record arity))) + + (define (operator . arguments) + (if (not (= (length arguments) arity)) + (error:wrong-number-of-arguments operator arity arguments)) + (apply (or (let per-arg + ((tree (operator-record-tree record)) + (args arguments)) + (let per-pred ((tree tree)) + (and (pair? tree) + (if ((caar tree) (car args)) + (if (pair? (cdr args)) + (or (per-arg (cdar tree) (cdr args)) + (per-pred (cdr tree))) + (cdar tree)) + (per-pred (cdr tree)))))) + default-operation + (error:no-applicable-methods operator arguments)) + arguments)) + + (hash-table/put! *generic-operator-table* operator record) + operator)) + +(define *generic-operator-table* + (make-eq-hash-table)) + +(define (make-operator-record arity) (cons arity '())) +(define (operator-record-arity record) (car record)) +(define (operator-record-tree record) (cdr record)) +(define (set-operator-record-tree! record tree) (set-cdr! record tree)) + +(define (assign-operation operator handler . argument-predicates) + (let ((record + (let ((record + (hash-table/get *generic-operator-table* operator #f)) + (arity (length argument-predicates))) + (if record + (begin + (if (not (= arity (operator-record-arity record))) + (error "Incorrect operator arity:" operator)) + record) + (let ((record (make-operator-record arity))) + (hash-table/put! *generic-operator-table* + operator + record) + record))))) + (set-operator-record-tree! record + (bind-in-tree argument-predicates + handler + (operator-record-tree record)))) + operator) + +(define (bind-in-tree keys handler tree) + (let loop ((keys keys) (tree tree)) + (let ((p.v (assq (car keys) tree))) + (if (pair? (cdr keys)) + (if p.v + (begin + (set-cdr! p.v + (loop (cdr keys) (cdr p.v))) + tree) + (cons (cons (car keys) + (loop (cdr keys) '())) + tree)) + (if p.v + (begin + (warn "Replacing a handler:" (cdr p.v) handler) + (set-cdr! p.v handler) + tree) + (cons (cons (car keys) handler) + tree)))))) |