Scheme - Land of Scheme - LISP は対称なり - より進んだデータ型とジェネリックプログラミング(データをジェネリックに扱う、シーケンスを使う、シーケンスの要素について繰り返す関数)

Land of Lisp
(オライリージャパン)
M.D. Conrad Barski (著) 川合 史朗 (翻訳)
原書: Land of LISP
Learn to Program in Lisp, One Game at a Time!

開発環境

• OS X El Capitan - Apple (OS)
• Emacs(Text Editor)
• Scheme (プログラミング言語)
• kscheme (github), Gauche, MIT/GNU Scheme, GNU Guile (処理系)

Land of Lisp (M.D. Conrad Barski (著)、川合 史朗 (翻訳)、オライリージャパン)の第2部(LISP は対称なり)、9章(より進んだデータ型とジェネリックプログラミング)、9.4(データをジェネリックに扱う、シーケンスを使う、シーケンスの要素について繰り返す関数)を Scheme で取り組んでみる。

9.4(データをジェネリックに扱う、シーケンスを使う、シーケンスの要素について繰り返す関数)

コード(Emacs)

(begin
  (define (map proc . lists)
    (define (exist-null? list-of-list)
      (if (null? list-of-list)
          #f
          (let ((lst (car list-of-list)))
            (if (null? lst)
                #t
                (exist-null? (cdr list-of-list))))))
    (define (heads list-of-list)
      (define (iter list-of-list)
        (if (null? list-of-list)
            '()
            (let ((lst (car list-of-list)))
              (if (not (pair? lst))
                  (display "error")
                  (cons (car lst)
                        (iter (cdr list-of-list)))))))
      (if (or (null? list-of-list)
              (exist-null? list-of-list))
          '()
          (iter list-of-list)))
    (define (rests list-of-list)
      (define (iter list-of-list)
        (if (null? list-of-list)
            '()
            (let ((lst (car list-of-list)))
              (if (not (pair? lst))
                  (display "error")
                  (cons (cdr lst)
                        (iter (cdr list-of-list)))))))
      (if (or (null? list-of-list)
              (exist-null? list-of-list))
          '()
          (iter list-of-list)))
    (define (iter list-of-list)
      (let ((args (heads list-of-list)))
        (if (null? args)
            '()
            (cons (apply proc args)
                  (iter (rests list-of-list))))))
    (if (null? lists)
        (display "error")
        (iter lists)))

  (define (string-map proc . strings)
    (list->string
     (apply map proc
            (map string->list strings))))
  
  (define (for-each proc . lists)
    (define (exist-null? list-of-list)
      (if (null? list-of-list)
          #f
          (let ((lst (car list-of-list)))
            (if (null? lst)
                #t
                (exist-null? (cdr list-of-list))))))
    (define (heads list-of-list)
      (define (iter list-of-list)
        (if (null? list-of-list)
            '()
            (let ((lst (car list-of-list)))
              (if (not (pair? lst))
                  (display "error")
                  (cons (car lst)
                        (iter (cdr list-of-list)))))))
      (if (or (null? list-of-list)
              (exist-null? list-of-list))
          '()
          (iter list-of-list)))
    (define (rests list-of-list)
      (define (iter list-of-list)
        (if (null? list-of-list)
            '()
            (let ((lst (car list-of-list)))
              (if (not (pair? lst))
                  (display "error")
                  (cons (cdr lst)
                        (iter (cdr list-of-list)))))))
      (if (or (null? list-of-list)
              (exist-null? list-of-list))
          '()
          (iter list-of-list)))
    (define (iter list-of-list)
      (let ((args (heads list-of-list)))
        (if (null? args)
            '()
            (begin (apply proc args)
                   (iter (rests list-of-list))))))
    (if (null? lists)
        (display "error")
        (iter lists))
    ;; undefined
    (if #f #f))

  (define print (lambda (obj) (write obj) (newline)))

  (define (sequence? obj) (or (list? obj) (string? obj) (vector? obj)))
  (define (sequence->list obj)
    (if (not (sequence? obj))
        (begin (display "Invalid type: sequence->list -- ")
               (print obj))
        (cond ((list? obj) obj)
              ((string? obj) (string->list obj))
              ((vector? obj) (vector->list obj)))))

  (define (reduce op . args)
    (define (iter result items)
      (if (null? items)
          result
          (iter (op result (car items)) (cdr items))))
    (let ((init (if (null? (cdr args))
                    (car (sequence->list (car args)))
                    (cadr args)))
          (rest (if (null? (cdr args))
                    (cdr (sequence->list (car args)))
                    (sequence->list (car args)))))
      (iter init rest)))
  
  (define (sum nums) (reduce + nums))

  (define (generic-map result-type proc seq)
    (cond ((eq? result-type 'string)
           (list->string (map proc (sequence->list seq))))
          ((eq? result-type 'list)
           (map proc (sequence->list seq)))))
  
  (print (reduce + '(3 4 6 5 2)))

  (print (reduce (lambda (best item)
                   (if (and (even? item) (> item best))
                       item
                       best))
                 '(7 4 6 5 2)
                 0))

  (print (reduce (lambda (best item)
                   (if (and (even? item) (> item best))
                       item
                       best))
                 '(7 4 6 5 2)))
  (print (sum '(1 2 3)))
  (print (sum #(1 2 3 4 5)))

  (print (generic-map 'list
                      (lambda (x)
                        (if (eqv? x #\s)
                            #\S
                            x))
                      "this is a string"))  
  )

入出力結果(Terminal(kscheme), REPL(Read, Eval, Print, Loop))

$ ./kscheme sample4_2.scm
20
6
7
6
15
(#\t #\h #\i #\S #\space #\i #\S #\space #\a #\space #\S #\t #\r #\i #\n #\g)
$