On Lisp のユーティリティをいくつか

いくつか Gauche で書きました。写経がてら。前回読んだ時にあまり書いてないので、揃えておいた方が良いなぁと。
ざっくり書いただけなので、動かないところがあるかもしれません。

今 LET OVER LAMBDA Edition 1.0 と On Lisp を再読しているので、こういうのを揃えていこうと考えています。書きたいものがあるときにすぐに書き始められる状態を作っておかないといけないなぁと思った次第です。

以下コード。

	;; on lisp
	;; http://www.komaba.utmc.or.jp/~flatline/onlispjhtml/
	(define-module liv.onlisp.utils
	(use srfi-1)
	(use util.list)
	(export-all))
	(select-module liv.onlisp.utils)
	(define (single ls)
	(and (pair? ls)
	(null? (cdr ls))))
	(define (append1 ls obj)
	(append ls (list obj)))
	(define (append1! ls obj)
	(append! ls (list obj)))
	(define (mklist obj)
	(if (pair? obj)
	obj
	(list obj)))
	(define (flatten tree)
	(if (list? tree)
	(append (flatten (car tree))
	(if (null? (cdr tree))
	'()
	(flatten (cdr tree))))
	(mklist tree)))
	(define group slices)
	(define (prune test tree)
	(fold-right (lambda (e acc)
	(if (pair? e)
	(cons (prune test e) acc)
	(if (test e)
	acc
	(cons e acc))))
	'() tree))
	(define (before x y ls)
	(and (not (null? ls))
	(let1 a (car ls)
	(cond ((test y a) => (lambda (b)
	(not b)))
	((test x a) ls)
	(else (before x y (cdr ls) :test test))))))
	(define (after x y ls)
	(let1 rest (before y x ls)
	(and rest (member x rest))))
	(define (duplicate obj ls)
	(member obj (cdr (member obj ls))))
	(define (split-if fn ls)
	(let rec ((ls ls)(acc '()))
	(if (or (null? ls)
	(fn (car ls)))
	(values (reverse acc) ls)
	(rec (cdr ls)(cons (car ls) acc)))))
	(define (most fn ls)
	(if (null? ls)
	(values '() -inf.0)
	(with-module gauche.collection
	(fold2 (lambda (e ret max)
	(let1 score (fn e)
	(if (< max score)
	(values e score)
	(values ret max)))) '() -inf.0 ls))))
	(define (best fn ls)
	(if (null? ls)
	'()
	(fold (lambda (e acc)
	(if (fn e acc)
	e
	acc))(car ls) ls)))
	(define (mostn fn ls)
	(if (null? ls)
	(values '() -inf.0)
	(with-module gauche.collection
	(fold2 (lambda (e ret max)
	(let1 score (fn e)
	(cond ((< max score)(values (list e) score))
	((= max score)(values (append ret (list e)) max))
	(else (values ret max)))))
	'() -inf.0 ls))))
	(define (mapa-b fn a b . step)
	(let-optionals* step ((step 1))
	(let rec ((i a)(end b)(acc '()))
	(if (< end i)
	(reverse acc)
	(rec (+ i step) end (cons (fn i) acc))))))
	(define (map0-n fn n)
	(mapa-b fn 0 n))
	(define (map1-n fn n)
	(mapa-b fn 1 n))
	(define (map-> fn start test-fn succ-fn)
	(let rec ((i start)(acc '()))
	(if (test-fn i)
	(reverse acc)
	(rec (succ-fn i)(cons (fn i) acc)))))
	(define (mappend fn . lss)
	(apply append (apply map fn lss)))
	(define (rmap fn . lss)
	(apply map (lambda (e)
	(if (list? e)
	(rmap fn e)
	(fn e))) lss))
	(define (mkstr . args)
	(with-output-to-string
	(lambda ()
	(dolist (a args)
	(display a)))))
	(define (symb . args)
	(string->symbol (apply mkstr args)))
	(define (explode sym)
	(map (compose string->symbol string)
	((compose string->list symbol->string) sym)))
	(define (fif pred then . else)
	(let-optionals* else ((else #f))
	(lambda x
	(if (apply pred x)
	(apply then x)
	(if else
	(apply else x))))))
	(define (fint fn . funs)
	(if (null? funs)
	fn
	(let1 chain (apply fint funs)
	(lambda x
	(and (apply fn x)(apply chain x))))))
	(define (fun fn . funs)
	(if (null? funs)
	fn
	(let1 chain (apply fint funs)
	(lambda x
	(or (apply fn x)(apply chain x))))))
	(define (lrec rec . base)
	(let-optionals* base ((base '()))
	(letrec ((self (lambda (lst)
	(if (null? lst)
	(if (procedure? base)
	(base)
	base)
	(rec (car lst)
	(lambda ()
	(self (cdr lst))))))))
	self)))
	(provide "liv.onlisp.utils")

view raw onlisp.utils.scm hosted with ❤ by GitHub