path: root/ps02_generics/full-gen-seq.scm

;;;;    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

|#