Schemeによる純粋関数型プログラミングのサンプル

pure.scm

;; -*- coding: utf-8 -*-
;;
;; pure.scm
;; 2019-5-2 v1.03
;;
;; ＜内容＞
;;   Schemeによる純粋関数型プログラミングのサンプルです。
;;   実行するまで副作用を生じない「アクション」によって、プログラムを組み立てます。
;;   (R7RS対応)
;;
;; ＜参考＞
;;   ・「純粋関数型JavaScriptのつくりかた」
;;     http://qiita.com/hiruberuto/items/810ecdff0c1674d1a74e
;;   ・「純粋関数型Common Lispをつくった話」
;;     https://hennin.info/2017/02/10/created-purely-functional-cl/
;;


;; ***** Gauche よりコピー *****

(define-library (gauche-mini)
  (export print $)
  (import (scheme base)
          (scheme write))

  (begin
    ;;;   'print' and '$' were copied from Gauche's source code and they are
    ;;;   under the following license.
    ;;;
    ;;;   Copyright (c) 2000-2017  Shiro Kawai  <shiro@acm.org>
    ;;;
    ;;;   Redistribution and use in source and binary forms, with or without
    ;;;   modification, are permitted provided that the following conditions
    ;;;   are met:
    ;;;
    ;;;   1. Redistributions of source code must retain the above copyright
    ;;;      notice, this list of conditions and the following disclaimer.
    ;;;
    ;;;   2. Redistributions in binary form must reproduce the above copyright
    ;;;      notice, this list of conditions and the following disclaimer in the
    ;;;      documentation and/or other materials provided with the distribution.
    ;;;
    ;;;   3. Neither the name of the authors nor the names of its contributors
    ;;;      may be used to endorse or promote products derived from this
    ;;;      software without specific prior written permission.
    ;;;
    ;;;   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
    ;;;   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
    ;;;   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
    ;;;   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
    ;;;   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
    ;;;   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
    ;;;   TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
    ;;;   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
    ;;;   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
    ;;;   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
    ;;;   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

    ;; 'print' (src/libio.scm)
    ;(define-in-module gauche (print . args) (for-each display args) (newline))
    (define (print . args) (for-each display args) (newline))

    ;; '$' (lib/gauche/common-macros.scm)
    (define-syntax $
      (syntax-rules ()
        (($ x . xs) (%$-split (x . xs) () ()))
        (($) (syntax-error "invalid $ form" ($)))))
    (define-syntax %$-split
      (syntax-rules ($ $*)
        ;; terminal condition
        ((_ ()   segs (e ...)) (%$-gen #f    ((e ...)           . segs)))
        ((_ ($)  segs (e ...)) (%$-gen (arg) ((e ... arg)       . segs)))
        ((_ ($*) segs (e ...)) (%$-gen arg   ((apply e ... arg) . segs)))
        ;; recurse
        ((_ ($ t ...)  segs (e ...)) (%$-split (t ...) ($  (e ...) . segs) ()))
        ((_ ($* t ...) segs (e ...)) (%$-split (t ...) ($* (e ...) . segs) ()))
        ((_ (t0 t ...) segs (e ...)) (%$-split (t ...) segs (e ... t0)))
        ))
    (define-syntax %$-gen
      (syntax-rules ($ $*)
        ;; terminal condition
        ((_ #f     (seg))  seg)
        ((_ formal (seg))  (lambda formal seg))
        ;; recurse
        ((_ type (seg0 $ (s ...) . segs))  (%$-gen type ((s ... seg0) . segs)))
        ((_ type (seg0 $* (s ...) . segs)) (%$-gen type ((apply s ... seg0) . segs)))
        ))
    ))


;; ***** 純粋関数型プログラム用ライブラリ *****

(define-library (pure-func)
  (export pure bind exec wrap)
  (import (scheme base))

  (begin
    ;; pure は、値 a をとって「実行すると値 a を返すアクション」を返す
    (define pure (lambda (a) (lambda () a)))

    ;; bind は、アクション m と 関数 f を結合したアクションを作る。
    ;; 使い方は、((bind m) f) となる。
    ;; ここで、関数 f を (lambda (x) (n x)) のようにすると、
    ;; アクション m の実行結果 x を次のアクション n に渡すことができる。
    ;; (↓改造して、アクション m が多値を返すケースにも対応してみた)
    ;(define bind (lambda (m) (lambda (f) (lambda () ((f (m)))))))
    (define bind (lambda (m) (lambda (f) (lambda () ((call-with-values m f))))))

    ;; exec は、アクション m を実行する
    (define exec (lambda (m) (m)))

    ;; wrap は、関数 f をアクションに変換する
    ;; (↓改造して、f が複数の引数を取るケースにも対応してみた)
    ;(define wrap (lambda (f) (lambda (a) (lambda () (f a)))))
    (define wrap (lambda (f) (lambda a (lambda () (apply f a)))))
    ))


;; ***** プログラムのサンプル *****

(import (scheme base)
        ;(only (gauche base) print $)
        (gauche-mini)
        (pure-func)
        (only (srfi 13) string-upcase))

;; アクションの定義
(define action-print         (wrap (lambda a (apply print a) (apply values a))))
(define action-read-line     (wrap read-line))
(define action-string-upcase (wrap string-upcase))
(define action-string-append (wrap string-append))
(define action-values        (wrap values))

;; プログラム1
;(define program1
;  ((bind (pure "abc"))                         (lambda (x)
;  ((bind (action-print x))                     (lambda (x)
;  ((bind (action-string-append "zzz" x "zzz")) (lambda (x)
;  ((bind (action-print x))                     (lambda (x)
;  ((bind (action-string-upcase x))             (lambda (x)
;  (action-print x))
;  )) )) )) )) ))

;; プログラム1B (Gaucheの $ を使って閉じ括弧を減らしたバージョン)
($ define program1B
   $ (bind (pure "abc"))                         $ lambda (x)
   $ (bind (action-print x))                     $ lambda (x)
   $ (bind (action-string-append "zzz" x "zzz")) $ lambda (x)
   $ (bind (action-print x))                     $ lambda (x)
   $ (bind (action-string-upcase x))             $ lambda (x)
   $ action-print x)

;; プログラム2 (多値のテスト)
($ define program2
   $ (bind (action-values "a" "b" "c")) $ lambda (x1 x2 x3)
   $ (bind (action-print x1 x2 x3))     $ lambda (x1 x2 x3)
   $ action-print x1 "-" x2 "-" x3)


;; ***** プログラムの実行 *****

(print "<program1>")
;(exec program1)
(exec program1B)
(print)

(print "<program2>")
(exec program2)
(print)

(print "HIT ENTER KEY!")
(flush-output-port)
(read-line)