Gauche:コンビネータプログラミング

Gauche:コンビネータプログラミング

yamasushi(2013/03/23 06:18:35 UTC)関数合成でコードを書くときにつかう小物とかいろいろまとめてみます。

空気を読んでlambdaにする。

applicableにしてしまうと影響が大きいような型をlambdaにする。 

(define-method x->^ ((sym <symbol>)) (cut ~ <> sym) )

(define-method x->^ ((dict <dictionary>) . rest )
  (if (null? rest)
    (cut dict-get dict <> )
    (cut dict-get dict <> (car rest) ) ) )

(define-method x->^ ((lst <list>))
  (match lst
    [(x)      ($ list $ (x->^ x) $) ]
    [(x . xs) (pack$ cons (x->^ x) (x->^ xs)) ] ) )

(define-method x->^ ((vec <vector>))
  (^y (map-to <vector> (^z ((x->^ z) y) ) vec) ) )


gosh> ($ (cut <> 'cond-list ) $ x->^ $ flip~~ 'table (find-module 'gauche) )
#<gloc gauche#cond-list>

gosh> ($ (cut <> 'cond-li ) $ x->^ $ flip~~ 'table (find-module 'gauche) )
*** ERROR: #<hash-table eq? 0x91d3ed8> doesn't have an entry for key cond-li
Stack Trace:
_______________________________________
  0  (eval expr env)
        At line 173 of "/usr/local/share/gauche-0.9/0.9.4_pre3/lib/gauche/interactive.scm"

gosh> ($ (cut <> 'cond-li ) $ flip x->^ #f $ flip~~ 'table (find-module 'gauche) )
#f

flip , flipr , flipl 

; rotate list
; あとでよりよい解法がみつかるかもしれないので、とりあえずここで実装
; (1 2 3) --> (2 3 1)
(define (%rotate-left arg) (append (cdr arg) `(,(car arg)) ) )

; (1 2 3) --> (3 1 2)
(define %rotate-right
  (match-lambda
    [()    '()]
    [(x)   `(,x)]
    [(x y) `(,y ,x)]
    [(x . rest)
      (receive (h xs) ($ car+cdr $ %rotate-right rest)
        (cons* h x xs) ) ] ) )

; (flip f x y) == (f y x)
(define (flip f x y) (f y x) )

; (flipl f x y z) = (f y z x)
(define (flipl f . arg) ($ apply f $ %rotate-left arg) )

; (flipr f x y z) = (f z x y)
(define (flipr f . arg) ($ apply f $ %rotate-right arg) )

述語のリストpredsのどれかが真になるかどうかチェックする 

; 述語のリストpredsのどれかが真になるかどうかチェックする
; gosh> (any-preds `(,#/^foo/ ,#/^hoge/) "hoge")
; #<<regmatch> 0xa0a4140>
; gosh> (any-preds `(,#/^foo/ ,#/^hoge/) "foo")
; #<<regmatch> 0xa0aaf00>
; gosh> (any-preds `(,#/^foo/ ,#/^hoge/) "fo")
; #f
(define (any-preds preds . arg)
  (any (^p (apply p arg)) preds) )
(define (any-preds$ preds) (pa$ any-preds preds))

(※ any-predがすでにありました。(yamasushi(2013/04/04 23:22:33 UTC) )

述語のリストpredsのすべてが真になるかどうかチェックする 

; 述語のリストpredsのすべてが真になるかどうかチェックする
; gosh> (every-preds `(,string? ,#/^hoge/) 2)
; #f
; gosh> (every-preds `(,string? ,#/^hoge/) "hoge")
; #<<regmatch> 0xa0a47c0>
; gosh> (every-preds `(,string? ,#/^hoge/) "hoe")
; #f
(define (every-preds preds . arg)
  (every (^p (apply p arg)) preds) )
(define (every-preds$ preds) (pa$ every-preds preds))

(※ envery-predがすでにありました。(yamasushi(2013/04/04 23:22:33 UTC) )

thunkでつつむ 

;thunkでつつむ
(define (wrap-thunk proc . arg) (cut apply proc arg) )

評価結果の関数を合成する 

; 評価結果の関数を合成する
; f:A->(B-C) , g:A->B ----> A->C
(define (apply-compose f g)
  (^ x ((apply f x) (apply g x))) )

返り値を拡張する 

;返り値を拡張する
; ok?....これに失敗すると返り値は#f
; fが関数でないなら#f
(define (if-*fn$ f ok? :optional (trans identity) )
  (and (procedure? f)
    (^ arg
      (let1 r (apply f arg)
        (and r (ok? r) (trans r) ) ) ) ) )

(define if-listfn$     (cut if-*fn$ <> pair? ) )
(define if-car-listfn$ (cut if-*fn$ <> pair? car    ) )
(define if-stringfn$   (cut if-*fn$ <> (complement string-null?) ) )

(define (car-listfn$ f)
  (and (procedure? f)
    (^ x
      (let1 r (apply f x)
        (if (null? r) '() (car r) ) ) ) ) )

andfn$ #fを受け取ると処理せずに#fを返すようにする 

; ($ .. $ ..)のなかで使う。途中で#fが返ると#fをかえすように
;andfn$ ... f .... 元の関数、#fを渡すと identityを返す
(define (andfn$ f)
  (if f
    (^x (and x (f x) ) )
    identity ) )

;andfn-fn$ ... f .... 元の関数、#fを渡すと identityを返す
; mはfilterやmapのような関数
(define (andfn-fn$ m f)
  (if f
    (andfn$ ($ m f $) )
    identity ) )

;andfn-map$ ... f .... 元の関数、#fを渡すと identityを返す
(define andfn-map$ ($ andfn-fn$ map $))

;andfn-filter$ ... f .... 元の関数、#fを渡すと identityを返す
(define andfn-filter$ ($ andfn-fn$ filter $))

tee 

; .$ の途中にはさんで中身をのぞくため
(define (tee outfn . arg)
  (apply outfn  arg)
  (apply values arg) )

(define (tee$ outfn) ($ tee outfn $*) )

(define peek$ tee$) ; 別名

teeで出力 

; ファイル出力
(define (tee-file proc path . arg)
  (apply tee ($ with-output-to-file (sys-normalize-pathname path :expand #t)
              $ wrap-thunk proc $*) arg ) )
(define (tee-file$ proc path) ($ tee-file proc path $*))

; logファイル出力(既存のファイルがあれば追加する)
(define (tee-logfile proc path . arg)
  (apply tee ($ (cut with-output-to-file
                      (sys-normalize-pathname path :expand #t)
                      <> :if-exists :append)
              $ wrap-thunk proc $*) arg ) )
(define (tee-logfile$ proc path) ($ tee-logfile proc path $*))

(define (tee-format p fmt . arg)
  (apply tee ($ format p fmt $* ) arg) ) 

(define (tee-format-stderr fmt . arg)
  (apply tee-format (standard-error-port) fmt arg))

(define (tee-format-stdout fmt . arg)
  (apply tee-format (standard-output-port) fmt arg))

(define (tee-format-stderr$ fmt) ($ tee-format-stderr fmt $*) )
(define (tee-format-stdout$ fmt) ($ tee-format-stdout fmt $*) )

tee-sleep 

(define (tee-nanosleep n . arg)
  (apply tee (^ _ (sys-nanosleep n) ) arg ) )

(define (tee-sleep n . arg)
  (apply tee (^ _ (sys-sleep n) ) arg ) )

(define (tee-sleep$     n) ($ tee-sleep     n $*) )
(define (tee-nanosleep$ n) ($ tee-nanosleep n $*) )

pack$ 

; http://chaton.practical-scheme.net/gauche/a/2012/06/01#entry-4fc95222-84c26
; あと、関係無いですがpack$とlist-pack$は逆にした方が
; (list-pack$を最初に定義して、それを使ってpack$を定義する) 方が素直じゃないかなあ?
; apply する時には既にリストは出来てるので apply list ... は意味が無いような。
;(define (list-pack$ . fs) (^ xs (map (cut apply <> xs) fs)))
;(define (pack$ p . fs) ($ p $* (apply list-pack$ fs) $*))

; 手続き列に値を通して、リストにするような手続きを返す
; ( (list-pack$ f g h) x ) ---> ( (f x) (g x) (h x) )
; ( (list-pack$ car cdr) '(1 2 3) ) ----> ( 1 (2 3))
(define (list-pack$ . fs)
  (^ xs (map (cut apply <> xs) fs) ) )

; 手続き列に値を通して、指定手続きpackerで固める手続きを返す
; ((pack$ f g h) x) -----> (f (g x) (h x) )
(define (pack$ packer . fs)
  ($ packer $* (apply list-pack$ fs) $*) )

; 万能アクセサに値を通して、指定手続きで固める手続きを返す
(define (~pack$ packer . keys)
  (apply pack$ packer
    (map (^k (cut ~ <> k)) keys) ) )

; 手続き列に値を通して、多値にする手続きを返す
; ((values-pack$ f g ) x ) ----> (values (f x) (g x) )
(define values-pack$ (pa$ pack$ values))

; 手続き列に値を通して、ペアにするような手続きを返す
; ((cons-pack$ f g h ) x ) ----> ( (f x) (g x) . (h x) )
(define cons-pack$ (pa$ pack$ cons* ) )

; ペアの要素をマップする
(define (map-pair$ f g)
  (cons-pack$ ($ f $ car $) ($ g $ cdr $) ) )

; (key . 手続き)列に値を通して、連想リストにするような手続きを返す
; ( (alist-pack$  a f b g c h ) x ) ---> ( (a .(f x)) ( b .(g x)) (c . (h x)) )
; ( (alist-pack$  a car b cdr ) '(1 2 3) ) ----> ( (a .1) (c . (2 3)) )
(define (alist-pack$ . kvs)
  (^ xs (map
          (cons-pack$
            car
            ($ (cut apply <> xs) $ cadr $) )
          (slices kvs
Topics
Sponsored Links
Search
Recent Changes
More ...
Last modified : 2013/04/28 03:41:33 UTC
WiLiKi 0.8.3 running on Gauche 0.9.15-p2