diff options
Diffstat (limited to 'ps02_generics/full-gen-seq.scm')
-rw-r--r-- | ps02_generics/full-gen-seq.scm | 632 |
1 files changed, 632 insertions, 0 deletions
diff --git a/ps02_generics/full-gen-seq.scm b/ps02_generics/full-gen-seq.scm new file mode 100644 index 0000000..e91ce30 --- /dev/null +++ b/ps02_generics/full-gen-seq.scm @@ -0,0 +1,632 @@ +;;;; Generic sequence operator definitions +;;;; Filled in by Bryan Newbold for 6.945 problem set #2, Feb 19 2009 + +; ===================== Problem 2.1 ======================= + +(load "ghelper.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: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: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?) + +;;;;;;;;;;;;;;; My Additions ;;;;;;;;;;;;;;;;;; + +;;; sequence:construct + +(define (sequence:construct sequence-type . items) + (if (null? items) + (sequence:null sequence-type) + (let loop ((things items) + (seq (sequence:null sequence-type))) + (if (null? things) + seq + (loop (cdr things) + (sequence:add-item seq (car things))))))) + +(define sequence:add-item + (make-generic-operator 2 #f)) + +(assign-operation sequence:add-item (lambda (a b) + (string-append a (string b))) + string? any?) +(assign-operation sequence:add-item (lambda (a b) + (append a (list b))) + list? any?) +(assign-operation sequence:add-item (lambda (a b) + (vector-append a (vector b))) + vector? any?) + + +#| Test sequence:construct + +(sequence:construct string? 1 2 3 4) +;Value: "1234" + +(sequence:construct vector? 'asdf 567 '(1 2 3)) +;Value: #(asdf 567 (1 2 3)) + +(sequence:construct list? (sequence:construct string? "asdf" 's 45) 1) +;Value: ("asdfs45" 1) + +(sequence:construct string?) +;Value: "" + +|# + +;;; sequence:generate + +(define sequence:generate + (make-generic-operator 3 #f)) + +(define (generate-string n f) + (if (zero? n) + (string (f n)) + (string-append (generate-string (- n 1) f) (string (f n))))) + +;(generate-string 3 sqrt) +;Value: "011.41421356237309511.7320508075688772" + +(assign-operation sequence:generate (lambda (a b c) + (generate-string b c)) + (is-exactly string?) exact-integer? procedure?) +(assign-operation sequence:generate (lambda (a b c) + (generate-list b c)) + (is-exactly list?) exact-integer? procedure?) +(assign-operation sequence:generate (lambda (a b c) + (generate-vector b c)) + (is-exactly vector?) exact-integer? procedure?) + +#| Test sequence:generate +(sequence:generate string? 4 (lambda (x) + (string-ref "abcdefghijklmno" (* 2 x)))) +;Value: "acegi" + +(sequence:generate list? 5 square) +;Value: (0 1 4 9 16) + +(sequence:generate vector? 10 string) +;Value: #("0" "1" "2" "3" "4" "5" "6" "7" "8" "9") + +|# + +;;; sequence:map +; I didn't do a formal check for arity of the mapping function because I don't +; really know how to... + +(define (sequence:map f . sequences) + (if (null? sequences) + (error "Need at least one sequence to map over") + (let ((type? (sequence:type (car sequences))) + (size? (lambda (x) + (equal? (sequence:size (car sequences)) + (sequence:size x))))) + (if (not (for-all? (cdr sequences) type?)) + (error "All sequences for map must be of the same type" + sequences)) + (if (not (for-all? (cdr sequences) size?)) + (error "All sequences for map must be of the same size" + sequences)) + (sequence:map-by-type type? f sequences)))) + +(define sequence:map-by-type + (make-generic-operator 3 #f)) + +; wow, this one sucks! +(assign-operation sequence:map-by-type + (lambda (a b c) + (sequence:generate string? (- (string-length (car c)) 1) + (lambda (n) + (apply b (map + (lambda (x) + (substring x n (+ 1 n))) + c))))) + (is-exactly string?) procedure? list?) +(assign-operation sequence:map-by-type (lambda (a b c) + (apply map b c)) + (is-exactly list?) procedure? list?) +(assign-operation sequence:map-by-type (lambda (a b c) + (apply vector-map b c)) + (is-exactly vector?) procedure? list?) + +#| Test sequence:map +(sequence:map + "123" '(1 1 1)) +;All sequences for map must be of the same type ("123" (1 1 1)) + +(sequence:map + "1234" "11111") +;All sequences for map must be of the same size ("1234" "11111") + +(sequence:map + '(1 2 3) '(1 1 1)) +;Value: (2 3 4) + +(define (wrap-paren s) + (string-append "(" s ")")) +(wrap-paren "asfd") +;Value: "(asfd)" + +(sequence:map wrap-paren "abcdEfg") + +(define (wrap-paren2 s1 s2) + (string-append "(" s1 ", " s2 ")")) +(wrap-paren2 "one" "two") +;Value: "(one, two)" + +(sequence:map wrap-paren2 "one" "two") +;Value: "(o, t)(n, w)(e, o)" + +|# + +;;; sequence:for-each +; just throw away the map result... not really correct for strings because +; map functions must return strings which are then appended, but for-each +; functions shouldn't have to return strings + +(define (sequence:for-each f . sequences) + (apply sequence:map f sequences) + '()) + +#| Testing sequence:for-each + +(sequence:for-each pp '(1 2 3 4)) +;1 +;2 +;3 +;4 +;Value: () + +|# + +;;; sequence:get-index + +(define sequence:get-index + (make-generic-operator 2 #f)) + +(define string-get-index + (lambda (s f) + (let next ((len (string-length s)) + (n 0)) + (if (equal? n len) #f) + (if (f (substring s n (+ 1 n))) + n + (next len (+ 1 n)))))) + +(define vector-get-index + (lambda (v f) + (let next ((len (vector-length v)) + (n 0)) + (if (eq? (+ 1 n) len) #f + (if (f (vector-ref v n)) + n + (next len (+ 1 n))))))) + +(assign-operation sequence:get-index string-get-index string? procedure?) +(assign-operation sequence:get-index find-matching-item list? procedure?) +(assign-operation sequence:get-index vector-get-index vector? procedure?) + +#| Testing sequence:get-index + +(sequence:get-index "asdf" identity) +; 0 + +(define (nicenum n) + (exact-integer? (sqrt n))) +(nicenum 5) +; #f +(nicenum 64) +; #t +(sequence:get-index '(2351 34 3 4 215 3) nicenum) +; 4 +(sequence:get-index '(1 2 3 4 5) (lambda (x) (eq? x 100))) +; #f +(sequence:get-index #(1 2 3 5 7 8 10) nicenum) +; 0 +(sequence:get-index #(2 3 5 7 8 10) nicenum) +; #f + +|# + +;;; sequence:get-element +; exact same as get-index, only returns the element + +(define sequence:get-element + (make-generic-operator 2 #f)) + +(define string-get-element + (lambda (s f) + (let next ((len (string-length s)) + (n 0)) + (if (equal? n len) #f) + (if (f (substring s n (+ 1 n))) + (substring s n (+ 1 n)) + (next len (+ 1 n)))))) + +(define vector-get-element + (lambda (v f) + (let next ((len (vector-length v)) + (n 0)) + (if (eq? (+ 1 n) len) #f + (if (f (vector-ref v n)) + (vector-ref v n) + (next len (+ 1 n))))))) + +(assign-operation sequence:get-element string-get-element string? procedure?) +(assign-operation sequence:get-element list-search-positive list? procedure?) +(assign-operation sequence:get-element vector-get-element vector? procedure?) + +#| Testing sequence:get-element + +(sequence:get-element "asdf" identity) +; "a" + +(sequence:get-element '(2351 34 3 64 215 3) nicenum) +; 64 +(sequence:get-element '(1 2 3 4 5) (lambda (x) (eq? x 100))) +; #f +(sequence:get-element #(1 2 3 5 7 8 10) nicenum) +; 1 +(sequence:get-element #(2 3 5 7 8 10) nicenum) +; #f + +|# + +;;; sequence:filter + +(define (sequence:filter sequence predicate) + (letrec ((base (sequence:null (sequence:type sequence))) + (chomp (lambda (x) + (if (predicate x) + (set! base (sequence:append base + (sequence:construct + (sequence:type sequence) + x)))) + x))) + (sequence:for-each chomp sequence) + base)) + +#| Test sequence:filter +(sequence:filter '(1 2 3 4 5 6 7) nicenum) +;Value: (1 4) + +(sequence:filter "this is a sentance" identity) +;Value: "ecnatnes a si siht" +; ugh, wrong order, don't know why only this... + +(sequence:filter #(1 4 9 16 25) nicenum) +;Value: #(1 4 9 16 25) +|# + +;;; sequence:fold-left + +(define (sequence:fold-left f init sequence) + (letrec ((base init) + (chomp (lambda (x) + (set! base (f base x)) + x))) + (sequence:for-each chomp sequence) + base)) + +#| +(sequence:fold-left list 'start '(a b c)) +;Value: (((end a) b) c) + +(sequence:fold-left string-append "first word" "abc") +;Value: "first wordcba" + +|# + +;;; sequence:fold-right + +(define (sequence:fold-right f init sequence) + (if (sequence:null? sequence) + init + (f (sequence:ref sequence 0) + (sequence:fold-right f + init + (sequence:subsequence + sequence 1 + (sequence:size sequence)))))) + +#| test sequence-right +(sequence:fold-right list 'end '(a b c)) +;Value: (a (b (c end))) + +(sequence:fold-right list 'end "abc") +;Value: (#\a (#\b (#\c end))) + +(sequence:fold-right list 'end #('a 'b 'c)) +;Value: ((quote a) ((quote b) ((quote c) end))) + +|# + +; ======================== Problem 2.2 ========================= + + +(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)))) + +(define string->vector (compose list->vector string->list)) +(define vector->string (compose list->string vector->list)) + +; (string->vector "asdf") +;Value: #(#\a #\s #\d #\f) +; (vector->string #(1 2 3)) + +(define (sequence:append . sequences) + (if (null? sequences) + (error "Need at least one sequence for append") + (fold-right generic:binary-append + (sequence:null (sequence:type (car sequences))) + sequences))) + +(assign-operation generic:binary-append + (compose-2nd-arg append vector->list) + list? vector?) +(assign-operation generic:binary-append + (compose-2nd-arg append string->list) + list? string?) +(assign-operation generic:binary-append + (compose-2nd-arg vector-append list->vector) + vector? list?) +(assign-operation generic:binary-append + (compose-2nd-arg vector-append string->vector) + vector? string?) +(assign-operation generic:binary-append + (compose-2nd-arg string-append list->string) + string? list?) +(assign-operation generic:binary-append + (compose-2nd-arg string-append vector->string) + string? vector?) + +#| testing sequence:append +(sequence:append '(1 2 3)) +; (1 2 3) +(sequence:append) +; ERROR +(sequence:append '(1 2 3) "456") +;Value: (1 2 3 #\4 #\5 #\6) + +(sequence:append #(4 5 6) #(1 2 3) #(12 34 56)) +;Value: #(4 5 6 1 2 3 12 34 56) + +(sequence:append "asdf" "asdf") +;Value: "asdfasdf" + +(sequence:append '(1 3 4 5) #(6 7 8) "91011") +;Value: (1 3 4 5 6 7 8 #\9 #\1 #\0 #\1 #\1) +|# + + +;UNFINISHED: +;sequence:elements-equal? +;sequence:map +;sequence:for-each + +; ===================== Problem 2.4 ======================== + +(define (boolean<? a b) + (if (and (not b) a) + #t + #f)) + +(define (null<? a b) #f) + +(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))))))))) + +(define (generic:binary-less? a b) + (cond ((null? a) (if (null? b) (null<? a b) #t)) + ((null? b) #f) + ((boolean? a) (if (boolean? b) (boolean<? a b) #t)) + ((boolean? b) #f) + ((char? a) (if (char? b) (char<? a b) #t)) + ((char? b) #f) + ((number? a) (if (number? b) (< a b) #t)) + ((number? b) #f) + ((symbol? a) (if (symbol? b) (symbol<? a b) #t)) + ((symbol? b) #f) + ((string? a) (if (string? b) (string<? a b) #t)) + ((string? b) #f) + ((vector? a) (if (vector? b) (list<? a b) #t)) + ((vector? b) #f) + ((list? a) (if (list? b) (list<? a b) #t)) + ((list? b) #f) + (else (error "Unknown type: " a)))) + +(define generic:less? + (make-generic-operator 2 #f)) + +(assign-operation generic:less? generic:binary-less? any? any?) + +;(generic:less? "asdf" '(a b c)) +; #t + +(define (list->set l) + (let next ((last '()) + (l (sort l generic:less?))) + (if (null? l) '() + (if (equal? last (car l)) + (next last (cdr l)) + (cons (car l) (next (car l) (cdr l))))))) + +#| +(list->set '(1 2 3 2 4 3)) +;Value: (1 2 3 4) + +(list->set '(4 (5 6) "asdf" '() #(1 2 3))) +;Value: (4 "asdf" #(1 2 3) (5 6) (quote ())) +|# + +(define generic:sequence->set + (make-generic-operator 1 #f)) + +(assign-operation generic:sequence->set list->set list?) +(assign-operation generic:sequence->set + (compose list->set string->list) string?) +(assign-operation generic:sequence->set + (compose list->set vector->list) vector?) + +(define set:equal? equal?) + +(define (set:union a b) + (list->set (append a b))) + +(define (set:intersection a b) + (filter (lambda (x) (member x b)) a)) + +(define (set:difference a b) + (filter (lambda (x) (not (member x b))) a)) + +(define (set:strict-subset? a b) + (and (not (eq? (length a) (length b))) + (eq? (length a) (length (set:intersection a b))))) + +#| Test: + +(generic:sequence->set "asdfsadgsadgfwqef") +;Value: (#\a #\d #\e #\f #\g #\q #\s #\w) + +(set:equal? '(1 2 3) '(a b c)) +; #f +(set:equal? '(1 2 3) '(1 2 3)) +; #t + +(set:union (generic:sequence->set "asdjhwrenslvc") + (generic:sequence->set "wroughlkdxjqw")) +;Value: (#\a #\c #\d #\e #\g #\h #\j #\k #\l #\n #\o +; #\q #\r #\s #\u #\v #\w #\x) +(set:intersection (generic:sequence->set "asdjhwrenslvc") + (generic:sequence->set "wroughlkdxjqw")) +;Value: (#\d #\h #\j #\l #\r #\w) + +(set:difference '(1 2 3 4 5) '(2 4 5)) +; (1 3) + +(set:strict-subset? '(1 3) '(1 2 3 4 5 6)) +; #t +(set:strict-subset? '(1 3 0) '(1 2 3 4 5 6)) +; #f + +|# + |