個人的なSchemeプログラム文書

;; Scheme Examples
;; This Scheme program is for DrScheme
; Square x
(define (square x) (* x x))
;A function g2
(define (g2 x y)
  (cond ((= y 0) 1)
        ((= y 1) x)
        ((= y 2) (* x x))
        (else 0)))
; Factor of x
(define (factor x)
  (if (= x 0) 1 (* x (factor (- x 1)))))
; Check odd or even of x
(define (oe x)
  (if (= x 0) 0 (if (= (oe (- x 1)) 0) 1 0)))
; Get greater common divisor of x and y
(define (gcd2 x y)
  (if (= y 0) x (gcd2 y (remainder x y))))
; Car of nth position
(define (nth-car n l)
    (cond ((null? l) '())
          ((<= n 0) '())
          ((= n 1) (car l))
          (#t (nth-car (- n 1) (cdr l)))))

; Get list length
(define (listlen-iter l n)
    (if (null? l) n (listlen-iter (cdr l) (+ n 1))))
(define (listlen l)
  (listlen-iter l 0))

; Construct list backward from l1 to l2
(define (cons-bw l1 l2)
  (if (null? l1) l2
      (cons-bw (cdr l1) (cons (car l1) l2))))

; Sort symbol list
(define (sinsert-iter sym src dest)
  (if (null? src) (reverse (cons sym dest))
      (if (string>? (symbol->string sym) (symbol->string (car src)))
          (sinsert-iter sym (cdr src) (cons (car src) dest))
          (cons-bw dest (cons sym src)))))
(define (sinsert sym lst)
  (sinsert-iter sym lst (list)))
(define (sisort-1 src dest)
  (if (null? src) dest
      (sisort-1 (cdr src) (sinsert (car src) dest))))
(define (sisort lst)
  (sisort-1 lst (list)))

; Insert value to appropriate position
(define (insert-iter a src dest)
  (if (null? src) (reverse (cons a dest))
      (if (> a (car src))
          (insert-iter a (cdr src) (cons (car src) dest))
          (cons-bw dest (cons a src)))))
(define (insert a lst)
  (insert-iter a lst (list)))

; Sort list
(define (isort-1 src dest)
  (if (null? src) dest
      (isort-1 (cdr src) (insert (car src) dest))))
(define (isort lst)
  (isort-1 lst (list)))

; Find max and min from list
(define (find-max-min src max min)
  (if (null? src) (list max min)
      (find-max-min (cdr src)
              (if (< max (car src)) (car src) max)
              (if (> min (car src)) (car src) min))))
(define (max-min src)
  (find-max-min src (car src) (car src)))

; Reverse list
(define (reverse-1-iter src dest)
  (if (null? src) dest
      (reverse-1-iter (cdr src) (cons (car src) dest))))
(define (reverse-1 lst)
  (reverse-1-iter lst (list)))

; Recursive reverser
(define (reverse*-iter src dest)
  (if (null? src) dest
      (reverse*-iter (cdr src) (cons 
                                (if (list? (car src))
                                    (reverse* (car src))
                                    (car src))
                                dest))))
(define (reverse* lst)
  (reverse*-iter lst (list)))

; Leaves
(define (leaves-iter src dest)
  (if (null? src) dest
      (leaves-iter (cdr src) (if (list? (car src))
                                  (leaves-iter (car src) dest)
                                  (cons (car src) dest)))))
(define (leaves lst)
  (reverse (leaves-iter lst (list))))

; A set
; Is x element of P?
(define (element? x P)
  (cond ((null? P) #f)
        ((equal? x (car P)) #t)
        (else (element? x (cdr P)))))
; Get intersection set of P and Q
(define (intersection-set P Q)
  (cond ((or (null? P) (null? Q)) '())
        ((element? (car P) Q) (cons 
                               (car P)
                               (intersection-set (cdr P) Q)))
        (else (intersection-set (cdr P) Q))))
; Get union set of P and Q
(define (union-set P Q)
  (cond ((null? P) Q)
        ((null? Q) P)
        ((element? (car P) Q) (union-set (cdr P) Q))
        (else (cons (car P) (union-set (cdr P) Q)))))
; Delete duplicated from P
(define (delete-duplicates P)
  (cond ((null? P) '())
        ((element? (car P) (cdr P)) (delete-duplicates (cdr P)))
        (else (cons (car P) (delete-duplicates (cdr P))))))
; Is P subset of Q
(define (subset? P Q)
  (cond ((null? P) #f)
        ((element? (car P) Q) 
         (if (null? (cdr P)) #t (subset? (cdr P) Q)))
        (else #f)))
; Get difference set of P and Q
(define (difference-set P Q)
  (cond ((null? Q) P)
        ((null? P) '())
        ((element? (car P) Q) (difference-set (cdr P) Q))
        (else (cons (car P) (difference-set (cdr P) Q)))))

; Formula expansion
; Symbol exp1
(define (exp1 x y)
  (if (null? y) '() (cons (list x (car y)) (exp1 x (cdr y)))))
; Symbol exp2
(define (exp2 x y)
  (if (null? x) '() (append (exp1 (car x) y) (exp2 (cdr x) y))))
; Symbol exp3
(define (exp3 x y)
  (if (null? y) '() (cons (append x (car y)) (exp3 x (cdr y)))))
; Symbol exp4
(define (exp4 x y)
  (if (null? x) '() (append (exp3 (car x) y) (exp4 (cdr x) y))))
; Symbol exp5
(define (exp5 x)
  (cond ((null? x) '())
        ((symbol? x) (list (list x)))
        (#t                            ;(list? x)
         (append (if (list? x) 
                               (exp6 (car x)) 
                               (exp5 (car x)))
                               (exp5 (cdr x))))))
; Symbol exp6
(define (exp6 x)
  (cond ((null? x) (list (list 1)))
        ((symbol? x) (list (list x)))
        (#t                            ;(list? x)
         (if (null? (cdr x)) 
             (exp5 (car x))
             (exp4 (exp5 (car x)) (exp6 (cdr x)))))))
; exp10
(define (exp-10-sub l s n)
  (if (or (and (= (remainder n 2) 1)
               (eq? s '*))
          (and (= (remainder n 2) 0)
               (eq? s '+)))
      (list (exp-10-sub l s (+ n 1)))
      (if (null? l) '()
          (if (list? (car l))
              (if (or (eq? (car (car l)) '*)
                      (eq? (car (car l)) '+)) 
                  (cons
                   (exp-10-sub (cdr (car l)) (car (car l)) (+ n 1))
                   (exp-10-sub (cdr l) s n))
                  (cons 
                   (exp-10-sub (car (car l)) s n) 
                   (exp-10-sub (cdr (car l)) s n)))
              (cons (car l) (exp-10-sub (cdr l) s n))))))
(define (exp-10 l)
  (cond ((null? l) '())
        ((list? l) (exp-10-sub (cdr l) (car l) 1))
        (else '())))
;exp11
(define (exp-11-sub-sub l n)
  (cond ((null? l) '())
        ((list? (car l)) (cons 
                          (if (null? (cdr (car l))) (car (car l))
                          (exp-11-sub (car l) (+ n 1)))
                          (exp-11-sub-sub (cdr l) n)))
        (else (cons (car l) (exp-11-sub-sub (cdr l) n)))))
;  (exp-11-sub (car l)
;  (exp-11-sub-sub (cdr l))
(define (exp-11-sub l n)
  (if (null? (cdr l))
      l
      (cons (if (= (remainder n 2) 1) '+ '*) (exp-11-sub-sub l n))))
(define (exp-11 l)
  (cond ((null? l) '())
        ((list? l) (exp-11-sub l 1))
        (else '())))
(define (expander exp)
	  (exp-11 (exp5 (exp-10 exp))))