LittleSchemer.scm

#lang scheme
(define atom? (let ((f1 pair?) (f2 not)) (lambda (x) (f2 (f1 x)))))

(define lat?
  (lambda (lat)
    (cond
      ((null? lat) #t)
      ((atom? (car lat)) (lat? (cdr lat)))
      (else #f)
      )))

(define member?
  (lambda (a lat)
    (cond
      ((null? lat) #f)
      ((eq? a (car lat)) #t)
      ( else (member? a (cdr lat)))
      )))

(define rember
  (lambda (a lat)
    (cond
      ((null? lat) '())
      ((eq? a (car lat)) (cdr lat))
      ( else (cons (car lat) (rember a (cdr lat))))
      )))

(define multirember
  (lambda (a lat)
    (cond
      ((null? lat) '())
      ((eq? a (car lat)) (multirember a (cdr lat)))
      ( else (cons (car lat) (multirember a (cdr lat))))
      )))

;; faltan los ejercicios del capitulo de numeros
(define =
  (lambda (n m)
    (cond
      ((> n m) #f)
      ((< n m) #f)
      (else #t)
      )))

(define numbered?
  (lambda (aexp)
    (cond
      ((atom? aexp) (number? aexp))
      ((eq? (car (cdr aexp)) '+ ) (and (numbered? (car aexp)) (numbered? (car (cdr (cdr aexp))))))
      ((eq? (car (cdr aexp)) '- ) (and (numbered? (car aexp)) (numbered? (car (cdr (cdr aexp))))))
      ((eq? (car (cdr aexp)) 'x ) (and (numbered? (car aexp)) (numbered? (car (cdr (cdr aexp))))))
      ((eq? (car (cdr aexp)) '^ ) (and (numbered? (car aexp)) (numbered? (car (cdr (cdr aexp))))))
      (else #f )
      )))

(define value
  (lambda (aexp)
    (cond
      ((atom? aexp) aexp)
      ((eq? (car (cdr aexp)) '+ ) (+ (value (car aexp)) (value (car (cdr (cdr aexp))))))
      ((eq? (car (cdr aexp)) '- ) (- (value (car aexp)) (value (car (cdr (cdr aexp))))))
      ((eq? (car (cdr aexp)) 'x ) (* (value (car aexp)) (value (car (cdr (cdr aexp))))))
      (else (expt (value (car aexp)) (value (car (cdr (cdr aexp))))))
      )))

; prefix notation
(define value1
  (lambda (aexp)
    (cond
      ((atom? aexp) aexp)
      ((eq? (car aexp) '+ ) (+ (value1 (car (cdr aexp))) (value1 (car (cdr (cdr aexp))))))
      ((eq? (car aexp) '- ) (- (value1 (car (cdr aexp))) (value1 (car (cdr (cdr aexp))))))
      ((eq? (car aexp) 'x ) (* (value1 (car (cdr aexp))) (value1 (car (cdr (cdr aexp))))))
      (else (expt (value1 (car (cdr aexp))) (value1 (car (cdr (cdr aexp))))))
      )))

(define 1st-sub-exp
  (lambda (aexp)
    ( car (cdr aexp))))

(define 2nd-sub-exp
  (lambda (aexp)
    ( car (cdr (cdr aexp)))))

(define operator 
  (lambda (aexp)
    (car aexp)))

(define value2
  (lambda (aexp)
    (cond
      ((atom? aexp) aexp )
      ((eq? (operator aexp) '+ ) (+ (value2 (1st-sub-exp aexp)) (value2 (2nd-sub-exp aexp))))
      ((eq? (operator aexp) '- ) (- (value2 (1st-sub-exp aexp)) (value2 (2nd-sub-exp aexp))))
      ((eq? (operator aexp) 'x ) (* (value2 (1st-sub-exp aexp)) (value2 (2nd-sub-exp aexp))))
      (else (expt (value2 (1st-sub-exp aexp)) (value2 (2nd-sub-exp aexp))))
      )))


; use () instead of numbers
(define sero?
  (lambda (n)
    (null? n)))

(define edd1
  (lambda (n)
    (cons '() n)))

(define zub1
  (lambda (n)
    (cdr n)))

(define plusp 
  (lambda (x y)
    (cond
      ((sero? y) x)
      (else (plusp (edd1 x) (zub1 y)))
      )))

; Chapter 7

(define set?
  (lambda (lat)
    (cond
      ((null? lat) #t)
      ((member? (car lat) (cdr lat)) #f)
      (else (set? (cdr lat)))
      )))

(define makeset
  (lambda (lat)
    (cond
      ((null? lat) '())
      ((member? (car lat) (cdr lat)) (makeset (cdr lat)))
      (else (cons (car lat) (makeset (cdr lat))))
    )))

;makeset with multirember
(define makeset-mr
  (lambda (lat)
    (cond
      ((null? lat) '())
      (else (cons (car lat) (makeset (multirember (car lat) (cdr lat)))))
    )))


(define subset
  (lambda (s1 s2)
    (cond
      ((null? s1) #t)
      (else (and (member? (car s1) s2) (subset (cdr s1) s2)))
      )))

(define eqset
  (lambda (s1 s2) (and (subset s1 s2) (subset s2 s1))))

(define intersect
  (lambda (set1 set2)
    (cond 
      ((null? set1) '())
      ((member? (car set1) set2 ) (cons (car set1) (intersect (cdr set1) set2)))
      (else (intersect (cdr set1) set2))
      )))

(define intersect-all
  (lambda (l-set)
    (cond 
      ((null? (cdr l-set)) (car l-set))
      (else (intersect (car l-set)(intersect-all (cdr l-set))))
      )))


(define a-pair?
  (lambda (p)
    (cond
      ((null? p) #f)
      ((null? (cdr p)) #f)
      ((null? (cdr (cdr p))) #t)
      (else #f)
       )))

(define first
  (lambda p
    (car p)))

(define second
  (lambda p
    (car (cdr p))))


(define eq?-c
  (lambda (c)
    (lambda (x)
      (eq? c x))))

(define build
  (lambda (s1 s2)
    (cons s1 (cons s2 '()))
    ))

(define seqR
  (lambda (new old lst)
    (cons old (cons new lst))
    ))

(define seqL
  (lambda (new old lst)
    (cons new (cons old lst))
    ))

(define insert-g
  (lambda (build)
    (lambda (test?)
      (lambda (new old l)
        (cond 
          ((null? l) '())
          ((test? (car l) old) (build new old (cdr l)))
          (else (cons (car l) (((insert-g build) test?) new old (cdr l))))
          )))))

(define insert-L (insert-g seqL))
(define insert-L-eq (insert-L eq?))


(define insert-L1 (insert-g (lambda (new old lst) ( cons new (cons old lst)))))

(define subst
  (lambda (new old lst)
     (cond 
       ((null? lst) '())
       ((eq? (car lst) old) 
        (cons new  (cdr lst)))
       (else (cons (car lst) (subst new old (cdr lst)))
       ))))

(define subst1 (insert-g ( lambda (new old lst) (cons new (cdr lst)) )))


(define atom-to-function 
  (lambda (x)
    (cond
      ((eq? x '+) +)
      ((eq? x 'x) *)
      ((eq? x '-) -)
      (else expt)
      )))

(define value3
  (lambda (aexp)
    (cond
      ((atom? aexp) aexp )
      (else ((atom-to-function (operator aexp))  (value3 (1st-sub-exp aexp)) (value3 (2nd-sub-exp aexp))))
      )))

(define multirember-f
  (lambda (test?)
    (lambda (a lat)
      (cond
        ((null? lat) '())
        ((test? a (car lat)) ((multirember-f test?) a (cdr lat)))
        ( else (cons (car lat) ((multirember-f test?) a (cdr lat))))
       ))))

(define multirember-eq? (multirember-f eq?))

(define eq-tuna? (eq?-c 'tuna))

(define multiremberT
  (lambda (test-k?)
    (lambda (lat)
      (cond
        ((null? lat) '())
        ((test-k? (car lat)) ((multiremberT test-k?) (cdr lat)))
        ( else (cons (car lat) ((multiremberT test-k?) (cdr lat))))
       ))))



(define multiinsertLR
  (lambda (new oldL oldR lat)
    (cond
      ( (null? lat) '())
      ( (eq? (car lat) oldL) (cons new (cons oldL (multiinsertLR new oldL oldR (cdr lat)))))
      ( (eq? (car lat) oldR) (cons oldR (cons new (multiinsertLR new oldL oldR (cdr lat)))))
      ( else (cons (car lat) (multiinsertLR new oldL oldR (cdr lat))))
     )))
      
(define multiinsertLR&co
  (lambda (new oldL oldR lat col)
    (cond
      ( (null? lat) (col '() '0 '0 ))
      ( (eq? (car lat) oldL) (multiinsertLR&co new oldL oldR (cdr lat) 
                                            (lambda (newlat l r)
                                              (col (cons new (cons oldL newlat))(add1 l) r )
                                              )
                                            ))
      ( (eq? (car lat) oldR) (multiinsertLR&co new oldL oldR (cdr lat) 
                                            (lambda (newlat l r)
                                              (col (cons oldR (cons new newlat)) l (add1 r) )
                                              )
                                            ))
      ( else (multiinsertLR&co new oldL oldR (cdr lat) 
                            (lambda (newlat l r)
                              (col (cons (car lat) newlat) l r )
                              )
                            ))
     )))

(define even?
  (lambda (n)
    (= (* (quotient n 2) 2) n) ))
;;    (eq? (* (/ n 2) 2) n)))

(define evens-only-* 
  (lambda (l)
     (cond
       ((null? l) '())
       ((atom? (car l)) (cond 
                          ((even? (car l)) (cons (car l) (evens-only-* (cdr l))))
                          (else (evens-only-* (cdr l)))))
       (else (cons (evens-only-* (car l)) (evens-only-* (cdr l))))
       )))


(define evens-only-*&co
  (lambda (l col)
     (cond
       ((null? l) (col '() 1 0))
       ((atom? (car l)) (cond 
                          ((even? (car l)) (evens-only-*&co (cdr l) 
                                                            (lambda (newl p s)
                                                              (col (cons (car l) newl)
                                                                   (* (car l) p ) s))
                                                            ))
                          (else (evens-only-*&co (cdr l)
                                                 (lambda (newl p s)
                                                              (col newl p (+ (car l) s )))
                                                 ))))
       (else (evens-only-*&co (car l) 
                              (lambda (al ap as)
                                (evens-only-*&co (cdr l)
                                                 (lambda (dl dp ds)
                                                   (col (cons al dl)
                                                        (* ap dp)
                                                        (+ as ds)
                                                        ))                
                               ))))
       )))

(define the-last-friend
  (lambda (newl product sum)
    (cons sum (cons product newl))
    ))


(define pick
  (lambda (i lat)
    (cond
      ((zero? ( sub1 i) ) (car lat))
      ( else (pick ( sub1 i) (cdr lat)))
      )))
    

(define looking 
  (lambda (a lat)
    (keep-looking a (pick 1 lat) lat)))


(define keep-looking
  (lambda (a sorn lat)
    (cond
      ( (number? sorn ) (keep-looking a (pick sorn lat) lat) )
      ( else (eq? a sorn) )
      )))

                    
(define shift
  (lambda (pair)
    ( build (first ( first pair))
            build ( second ( first pair ) (second pair)))))

(define length*
  (lambda (pora)
    (cond
      ((atom? pora) 1)
      (else (+ (length* (first pora)) (length* (second pora))))
    )))

(define eternity
  (lambda (x)
    (eternity x)))

(lambda (l)
  (cond
    ((null? l) 0)
    (else (add1 (eternity (cdr l) )))))

;;length 0
(lambda (length)
  (lambda (l)
    (cond
      ((null? l) 0)
      (else (add1 (length (cdr l) )))))
  eternity )

;;length <=1
((lambda (f)
  (lambda (l)
    (cond
      ((null? l) 0)
      (else (add1 (f (cdr l) ))))))
((lambda (g)
  (lambda (l)
    (cond
      ((null? l) 0)
      (else (add1 (g (cdr l) ))))))
  eternity ))

;;length <=2
((lambda (length)
  (lambda (l)
    (cond
      ((null? l) 0)
      (else (add1 (length (cdr l) ))))))
((lambda (length)
  (lambda (l)
    (cond
      ((null? l) 0)
      (else (add1 (length (cdr l) ))))))
((lambda (length)
  (lambda (l)
    (cond
      ((null? l) 0)
      (else (add1 (length (cdr l) ))))))
 eternity )))

;;mk-length 0
((lambda (mk-length) (mk-length eternity))
 (lambda (length)
  (lambda (l)
    (cond
      ((null? l) 0)
      (else (add1 (length (cdr l) )))))) )

;;mk-length <=1
((lambda (mk-length) (mk-length (mk-length eternity)))
 (lambda (length)
  (lambda (l)
    (cond
      ((null? l) 0)
      (else (add1 (length (cdr l) )))))) )

;;mk-length <=2
((lambda (mk-length) (mk-length (mk-length (mk-length eternity))))
 (lambda (length)
  (lambda (l)
    (cond
      ((null? l) 0)
      (else (add1 (length (cdr l) )))))) )



;;mk-length 0
((lambda (mk-length) (mk-length mk-length))
 (lambda (mk-length)
  (lambda (l)
    (cond
      ((null? l) 0)
      (else (add1 (mk-length (cdr l) )))))) )

;;mk-length 1
((lambda (mk-length) (mk-length mk-length))
 (lambda (mk-length)
  (lambda (l)
    (cond
      ((null? l) 0)
      (else (add1 ((mk-length eternity)(cdr l) )))))) )

;;length !!
((lambda (mk-length) (mk-length mk-length))
 (lambda (mk-length)
  (lambda (l)
    (cond
      ((null? l) 0)
      (else (add1 ((mk-length mk-length)(cdr l) )))))) )

;;extract (mk-length mk-length) -> length
;; but doesn't end
;;((lambda (mk-length) (mk-length mk-length))
;; (lambda (mk-length)
;;   ((lambda (length)
;;     (lambda (l)
;;       (cond
;;         ((null? l) 0)
;;         (else (add1 (length (cdr l) ))))))
;;     (mk-length mk-length)
;;      )))

;;instead extract (mk-length mk-length) into a function  (lambda (x) ((mk-length mk-length)x))
((lambda (mk-length) (mk-length mk-length))
 (lambda (mk-length)
  (lambda (l)
    (cond
      ((null? l) 0)
      (else (add1 ((lambda (x) ((mk-length mk-length)x)) (cdr l) )))))) )

;;and extract that lambda into a function "length"
((lambda (mk-length) (mk-length mk-length))
 (lambda (mk-length)
   (lambda (length)
     ((lambda (l)
       (cond
         ((null? l) 0)
         (else (add1 (length (cdr l) ))))))
      (lambda (x) ((mk-length mk-length)x))
      )))

;;extract the lambda length (doesn't  depend on mk-length)
((lambda (le) 
  ((lambda (mk-length) (mk-length mk-length))
   (lambda (mk-length)
     (le (lambda (x) ((mk-length mk-length)x))
     ))))
  (lambda (length)
       ((lambda (l)
          (cond
            ((null? l) 0)
            (else (add1 (length (cdr l) ))))))
       )
  )
;;we got mk-lentgth back and a bunch of strange lambda applications :)

;; extract those lambda combinations
(lambda (le) 
  ((lambda (mk-length) (mk-length mk-length))
   (lambda (mk-length)
     (le (lambda (x) ((mk-length mk-length)x))
     ))))


;; rename to get the APPLICATIVE ORDER Y COMBINATOR!!
(define Y
  (lambda (le) 
    ((lambda (f) (f f))
     (lambda (f)
       (le (lambda (x) ((f f)x))
           ))))
  )