yamasushi(2013/03/23 06:18:35 UTC)関数合成でコードを書くときにつかう小物とかいろいろまとめてみます。
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
; 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のどれかが真になるかどうかチェックする ; 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のすべてが真になるかどうかチェックする ; 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でつつむ (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) ) ) ) ) )
; ($ .. $ ..)のなかで使う。途中で#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 $))
; .$ の途中にはさんで中身をのぞくため (define (tee outfn . arg) (apply outfn arg) (apply values arg) ) (define (tee$ outfn) ($ tee outfn $*) ) (define peek$ 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 $*) )
(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 $*) )
; 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