Wolsty: lambdaを隠した書き方につかえる関数まとめ

これまで投稿してた Scheme で lambda を隠した書き方をするのにつかう関数の定義をまとめてみた。

(use-modules (srfi srfi-1)) ; assoc, fild-tail, fold, for-each, map, every, unfold

(define (echo x0 . fs) (fold (lambda (fi xi) (fi xi)) x0 fs))
(define (&$ . fs)    (lambda (x0) (fold (lambda (fi xi) (fi xi)) x0 fs)))
(define ($$ f0 . fs) (lambda xs (fold (lambda (fi xi) (fi xi)) (apply f0 xs) fs)))
(define (*~ f . <<)  (lambda >> (apply f (append << >>))))
(define (~* f . >>)  (lambda << (apply f (append << >>))))
(define (?~ f)       (lambda << (lambda >> (apply f (append << >>)))))
(define (~? f)       (lambda >> (lambda << (apply f (append << >>)))))
(define (-<$ . fs)   (lambda xs (map (lambda (f) (apply f xs)) fs)))
(define (//$ . fs)   (lambda (xs) (map (lambda (fi xi) (fi xi)) fs xs)))
(define (each f)     (lambda (xs) (map f xs)))
(define ($->& f)     (lambda (xs) (apply f xs)))
(define (&->$ f)     (lambda xs (apply f (list xs))))
(define (! . xs)     (lambda _ (apply values xs)))

(define (wnl . xs) (for-each write xs) (newline) (apply values xs))
(define (dnl . xs) (for-each display xs) (newline) (apply values xs))

(define (<&&> . fs)
  (if (null? fs)
    (lambda (o) #t)
; else
    (lambda (o)
      (let trace ((fs fs))
        (if (null? (cdr fs))
          ((car fs) o)
      ; else
          (and ((car fs) o) (trace (cdr fs)))
        )
      ) ; let
    ) ; lambda
  ) ; if
) ; define <&&>

(define (<||> . fs)
  (if (null? fs)
    (lambda (o) #f)
; else
    (lambda (o)
      (let trace ((fs fs))
        (if (null? (cdr fs))
          ((car fs) o)
      ; else
          (or ((car fs) o) (trace (cdr fs)))
        )
      ) ; let
    ) ; lambda
  ) ; if
) ; define <&&>

; Q : a->Boolean
; T : a->b
; F : a->b

(define (?: Q T F) (lambda (x) (if (Q x) (T x) (F x))))

; QTs : [(a->Boolean, a->b)]
; F   : a->b

(define (?:? QTs F)
  (lambda (x)
    (let seq ((QTs QTs))
      (cond
        ((null? QTs) (F x))
        (((caar QTs) x) ((cadr QTs) x))
        (else (seq (cdr QTs)))
      ) ; cond
    ) ; let seq
  ) ; lambda
) ; define ?:?

;; QTs : [(a->Boolean, b)]
;; F   : b

(define (?:! QTs F)
  (lambda (x)
    (let ((qt (find-tail (lambda (qt) ((car qt) x)) QTs)))
      (if qt (cadr qt) F)
    ) ; let qt
  ) ; lambda
) ; define ?:!

;; QTs : [(a, a->b)]
;; F   : a->b

(define (!:? QTs F . ==)
  (set! == (if (pair? ==) (cadr ==) equal?))
  (lambda (x)
    (let ((qt (assoc x QTs ==)))
      ((if qt (cadr qt) F) x)
    ) ; let qt
  ) ; lambda
) ; define !:?

;; QTs : [(a, b)]
;; F   : b

(define (!:! QTs F . ==)
  (set! == (if (pair? ==) (cadr ==) equal?))
  (lambda (x)
    (let ((qt (assoc x QTs ==)))
      (if qt (cadr qt) F)
    ) ; let qt
  ) ; lambda
) ; define !:!

(define ($.. f . fs)
  (set! fs (cons f fs))
  (lambda xs
    (let trace ((fs fs))
      (if (null? (cdr fs))
        (apply (car fs) xs)
    ; else
        (begin
          (apply (car fs) xs)
          (trace (cdr fs))
        )
      )
    ) ; let
  ) ; lambda
) ; define $..

(define new_Function.Effector.Property list)
(define Function.Effector.Property_instance? car)
(define Function.Effector.Property_getter    cadr)
(define Function.Effector.Property_setter    caddr)

;; instance? : Any->Boolean
;; getter    : a->b
;; setter    : a,b->a

(define (Function.Effector effProp replace)
  (lambda (o)
    ((Function.Effector.Property_setter effProp) o
      (replace ((Function.Effector.Property_getter effProp) o))
    )
  )
)

(define >E Function.Effector)

(define (Function.EffectorTo effProp replace)
  (lambda (o)
    (if ((Function.Effector.Property_instance? effProp) o)
      ((Function.Effector.Property_setter effProp) o
        (replace ((Function.Effector.Property_getter effProp) o))
      )
  ; else
      o
    )
  )
)
Sign up for free and join this conversation.
Sign Up
If you already have a Qiita account log in.