;=================================================================================== ; file: PCM20220423_SDFF_2.1.1 ; Racket code: PCM *** 2022/05/28 *** ;=================================================================================== #lang racket ;----------------------------------------------------------------------------------- ; SDFF, 2021, p.23 (display "SDFF, 2021, p.23")(newline) ; (define (compose f g) (lambda args (f (apply g args)))) ; ; SDFF, 2021, p.24 (display "SDFF, 2021, p.24")(newline) ((compose (lambda(x) (list 'foo x)) (lambda(x) (list 'bar x))) 'z1) ;----------------------------------------------------------------------------------- (define (compose2 f g) (define (the-composition . args) (f (apply g args))) the-composition) ; ((compose2 (lambda(x) (list 'foo x)) (lambda(x) (list 'bar x))) 'z2) ;---------------------------------------------------------------- (display "============================================")(newline) ; SDFF, 2021, p.25 (display "SDFF, 2021, p.25, n-th iterate of a function")(newline) ; (define ((iterate n) f) (if (= n 0) identity (compose f ((iterate (- n 1)) f)))) ; (define (identity x) x) (define (square x) (* x x)) ; (((iterate 3) square) 5) ;---------------------------------------------------------------- (display "============================================")(newline) ; SDFF, 2021, p.26 (display "SDFF, 2021, p.26, Arity")(newline) ; (define (parallel-combine h f g) (define(the-combination . args) (h (apply f args) (apply g args))) the-combination) ; (parallel-combine list (lambda (x y z) (list 'foo x y z)) (lambda (u v w) (list 'bar u v w))) ; ((parallel-combine list (lambda (x y z) (list 'foo x y z)) (lambda (u v w) (list 'bar u v w))) 'a 'b 'c) ;---------------------------------------------------------------- (display "============================================")(newline) ; SDFF, 2021, ARITY, p.27 (define inArities (make-hash)) ; (display "Arity, SDFF, 2021, p.27, spread-combine1")(newline) (define (spread-combine1 h f g) (define (get-arity foo) (hash-ref inArities foo)) (define (list-head args n) (take args n)) (hash-set! inArities f 2) (hash-set! inArities g 3) (let ((n (get-arity f))) (define (the-combination . args) (h (apply f (list-head args n)) (apply g (list-tail args n)))) ; list-tail is in racket the-combination)) ; (spread-combine1 list (lambda (x y) (list 'foo x y)) (lambda (u v w) (list 'bar u v w))) ; (display "Arity, SDFF, 2021, p.28, spread-combine1 1st call")(newline) ((spread-combine1 list (lambda (x y) (list 'foo x y)) (lambda (u v w) (list 'bar u v w))) 'a 'b 'c 'd 'e) ;---------------------------------------------------------------- ; SDFF, 2021, p.28 (define (restrict-arity proc nargs) (hash-set! inArities proc nargs) proc) ; (display "Arity, SDFF, 2021, p.27, spread-combine2")(newline) (define (spread-combine2 h f g) (define (get-arity foo) (hash-ref inArities foo)) (define (list-head args n) (take args n)) ; (hash-set! inArities f 2) (hash-set! inArities g 3) ; (let ((n (get-arity f)) (m (get-arity g))) (let ((t (+ n m))) (define (the-combination . args) (h (apply f (list-head args n)) (apply g (list-tail args n)))) (restrict-arity the-combination t)))) ; ; SDFF, 2021, p.28 (spread-combine2 list (lambda (x y) (list 'foo x y)) (lambda (u v w) (list 'bar u v w))) ; (display "Arity, SDFF, 2021, p.28, spread-combine2 1st call")(newline) ((spread-combine2 list (lambda (x y) (list 'foo x y)) (lambda (u v w) (list 'bar u v w))) 'a 'b 'c 'd 'e) ; (define (foo x y) (list 'foo x y)) (define(bar u v w) (list 'bar u v w)) (define xs '(a b c d e)) ; (display "Arity, SDFF, 2021, p.28, spread-combine2 2nd call")(newline) ((spread-combine2 list foo bar) 'a 'b 'c 'd 'e) (display "Arity, SDFF, 2021, p.28, spread-combine2 3rd call")(newline) (apply (spread-combine2 list foo bar) xs) ;---------------------------------------------------------------- ; SDFF, 2021, p.28 (display "Arity, SDFF, 2021, p.28, spread-combine3 with assert(ion)")(newline) ; (define (spread-combine3 h f g) (define (assert success-condition) (if success-condition #true (display "success-condition in assert: #false"))) (define (get-arity foo) (hash-ref inArities foo)) (define (list-head args n) (take args n)) ; (hash-set! inArities f 2) (hash-set! inArities g 3) ; (let ((n (get-arity f)) (m (get-arity g))) (let ((t (+ n m))) (define (the-combination . args) (assert (= (length args) t)) (h (apply f (list-head args n)) (apply g (list-tail args n)))) (restrict-arity the-combination t)))) ; (display "Arity, SDFF, 2021, p.28, spread-combine3 1st call")(newline) ((spread-combine3 list foo bar) 'a 'b 'c 'd 'e) (display "Arity, SDFF, 2021, p.28, spread-combine3 2nd call")(newline) (apply (spread-combine3 list foo bar) xs) ;---------------------------------------------------------------- (display "============================================")(newline) ; SDFF, 2021, p.30f., Multiple Values (display "Multiple Values, SDFF, 2021, p.30f")(newline) ; (display "Spread Apply, SDFF, 2021, p.30")(newline) ; (define (spread-apply f g) (define (assert success-condition) (if success-condition #true (display "success-condition in assert: #false"))) (define (get-arity foo) (hash-ref inArities foo)) (define (list-head args n) (take args n)) ; (hash-set! inArities f 2) (hash-set! inArities g 3) ; (let ((n (get-arity f)) (m (get-arity g))) (let ((t (+ n m))) (define (the-combination . args) (assert (= (length args) t)) (values (apply f (list-head args n)) (apply g (list-tail args n)))) (restrict-arity the-combination t)))) ; (spread-apply foo bar) (display ", SDFF, 2021, p.31, spread-apply, 1st call")(newline) ((spread-apply foo bar) 'a 'b 'c 'd 'e) (display ", SDFF, 2021, p.31, spread-apply, 2nd call")(newline) (apply (spread-apply foo bar) xs) ; (display "SDFF, 2021, spread-combine, p.31")(newline) ; (define (spread-combine h f g) (compose3 h (spread-apply f g))) ; (display "SDFF, 2021, compose3, p.32")(newline) ; (define (compose3 f g) (hash-set! inArities f 2) (hash-set! inArities g 1) (define (get-arity foo) (hash-ref inArities foo)) (define (the-composition . args) (call-with-values (lambda () (apply g args)) f)) (restrict-arity the-composition (get-arity g))) ; (display "SDFF, 2021, compose3, 1st call, p.32")(newline) ((compose3 foo (lambda(x) (values (list 'bar x) (list 'bar x))))'z) ; (spread-combine list foo bar) (display "SDFF, 2021, spread-combine, 1st call, p.32")(newline) ((spread-combine list foo bar) 'a 'b 'c 'd 'e) (display "SDFF, 2021, spread-combine, 2nd call, p.32")(newline) (apply (spread-combine list foo bar) xs) ;---------------------------------------------------------------- ; SDFF, 2021, p.33f. (display "============================================")(newline) (display "A Small Library, SDFF, 2021, p.33f")(newline) ; (display "SDFF, 2021, p.34, list-remove")(newline) ; remove the (index+1). element (define (list-remove lst index) (define (list-head args n) (take args n)) (append (list-head lst index)(list-tail lst (+ index 1)))) ; (list-remove xs 0) (list-remove xs 1) (list-remove xs 2) (list-remove xs 4) ; (display "SDFF, 2021, p.33, discard-argument")(newline) (define (discard-argument i) ;-------------------------------------- (define (get-arity foo) (hash-ref inArities foo)) ;-------------------------------------- (define (assert condition text irritant1 irritant2) (if (not (equal? condition #t)) (error text irritant1 irritant2) condition)) ;-------------------------------------- (assert (exact-nonnegative-integer? i) "(exact-nonnegative-integer? i) not true, because i = " i i) (lambda (f) (let ((m (+ (get-arity f) 1))) (define (the-combination . args) (assert (= (length args) m) "(= (length args) m) is not true, because of " (length args) m) (apply f (list-remove args i))) (assert (< i m) "(< i m) is not true, because :" i m) (restrict-arity the-combination m)))) ; (define (xyz x y z) (list 'foo x y z)) (hash-set! inArities xyz 3) (display "SDFF, 2021, p.33, discard-argument, 1st call")(newline) (((discard-argument 1) xyz) 'a 'b 'c 'd) (display "SDFF, 2021, p.33, discard-argument, 2nd call")(newline) (((discard-argument 2) xyz) 'a 'b 'c 'd) (define (foo2 . args) (list 'foo2 args)) (hash-set! inArities foo2 4) (display "SDFF, 2021, p.33, discard-argument, 3rd call")(newline) (((discard-argument 2) foo2) 'a 'b 'c 'd 'e) (display "SDFF, 2021, p.33, discard-argument, 4th call")(newline) (apply ((discard-argument 2) foo2) xs) ;=================================================================================== ; this is draft, only for personal use ; bug reports, improvement proposal are welcome: claus.moebus@uo.de ;===================================================================================