working on it ...

snippets
539
followers
4

# Scheme

This channel collects useful snippets for Scheme language
Sort by

Found 539 snippets

### Loop 4 times with condition

try=0
while [ $try -lt 4 ]; do try=$((try+1))
done

### Mini-kanren like logic programming in Scheme

Mini-kanren like logic programming in Scheme: sokuza-kanren.scm
;                    Quick miniKanren-like code
;
; written at the meeting of a Functional Programming Group
; (Toukyou/Shibuya, Apr 29, 2006), as a quick illustration of logic
; programming.  The code is really quite trivial and unsophisticated:
; it was written without any preparation whatsoever. The present file
;
; $Id: sokuza-kanren.scm,v 1.1 2006/05/10 23:12:41 oleg Exp oleg$

; Point 1: functions' that can have more (or less) than one result
;
; As known from logic, a binary relation xRy (where x \in X, y \in Y)
; can be represented by a _function_  X -> PowerSet{Y}. As usual in
; computer science, we interpret the set PowerSet{Y} as a multi-set
; (realized as a regular scheme list). Compare with SQL, which likewise
; uses multisets and sequences were sets are properly called for.
; Also compare with Wadler's representing failure as a list of successes.'
;
; Thus, we represent a 'relation' (aka non-deterministic function')
; as a regular scheme function that returns a list of possible results.
; Here, we use a regular list rather than a lazy list, just to be quick.

; First, we define two primitive non-deterministic functions;
; one of them yields no result whatsoever for any argument; the other
; merely returns its argument as the sole result.

(define (fail x) '())
(define (succeed x) (list x))

; We build more complex non-deterministic functions by combining
; the existing ones with the help of the following two combinators.

; (disj f1 f2) returns all the results of f1 and all the results of f2.
; (disj f1 f2) returns no results only if neither f1 nor f2 returned
; any. In that sense, it is analogous to the logical disjunction.
(define (disj f1 f2)
(lambda (x)
(append (f1 x) (f2 x))))

; (conj f1 f2) looks like a functional composition' of f2 and f1.
; Only (f1 x) may return several results, so we have to apply f2 to
; each of them.
; Obviously (conj fail f) and (conj f fail) are both equivalent to fail:
; they return no results, ever. It that sense, conj is analogous to the
; logical conjunction.
(define (conj f1 f2)
(lambda (x)
(apply append (map f2 (f1 x)))))

; Examples
(define (cout . args)
(for-each display args))
(define nl #\newline)

(cout "test1" nl
((disj
(disj fail succeed)
(conj
(disj (lambda (x) (succeed (+ x 1)))
(lambda (x) (succeed (+ x 10))))
(disj succeed succeed)))
100)
nl)
; => (100 101 101 110 110)

; Point 2: (Prolog-like) Logic variables
;
; One may think of regular variables as certain knowledge': they give
; names to definite values.  A logic variable then stands for
; improvable ignorance'.  An unbound logic variable represents no
; knowledge at all; in other words, it represents the result of a
; measurement _before_ we have done the measurement. A logic variable
; may be associated with a definite value, like 10. That means
; definite knowledge.  A logic variable may be associated with a
; semi-definite value, like (list X) where X is an unbound
; variable. We know something about the original variable: it is
; associated with the list of one element.  We can't say though what
; that element is. A logic variable can be associated with another,
; unbound logic variable. In that case, we still don't know what
; precisely the original variable stands for. However, we can say that it
; represents the same thing as the other variable. So, our
; uncertainty is reduced.

; We chose to represent logic variables as vectors:
(define (var name) (vector name))
(define var? vector?)

; We implement associations of logic variables and their values
; (aka, _substitutions_) as associative lists of (variable . value)
; pairs.
; One may say that a substitution represents our current knowledge
; of the world.

(define empty-subst '())
(define (ext-s var value s) (cons (cons var value) s))

; Find the value associated with var in substitution s.
; Return var itself if it is unbound.
; In miniKanren, this function is called 'walk'
(define (lookup var s)
(cond
((not (var? var)) var)
((assq var s) => (lambda (b) (lookup (cdr b) s)))
(else var)))

; There are actually two ways of implementing substitutions as
; associative list.
; If the variable x is associated with y and y is associated with 1,
; we could represent this knowledge as
; ((x . 1) (y . 1))
; It is easy to lookup the value associated with the variable then,
; via a simple assq. OTH, if we have the substitution ((x . y))
; and we wish to add the association of y to 1, we have
; to make rearrangements so to produce ((x . 1) (y . 1)).
; OTH, we can just record the associations as we learn them, without
; modifying the previous ones. If originally we knew ((x . y))
; and later we learned that y is associated with 1, we can simply
; prepend the latter association, obtaining ((y . 1) (x . y)).
; So, adding new knowledge becomes fast. The lookup procedure becomes
; more complex though, as we have to chase the chains of variables.
; To obtain the value associated with x in the latter substitution, we
; first lookup x, obtain y (another logic variable), then lookup y
; finally obtaining 1.
; We prefer the latter, incremental way of representing knowledge:
; it is easier to backtrack if we later find out our

; Unification is the process of improving knowledge: or, the process
; of measurement. That measurement may uncover a contradiction though
; (things are not what we thought them to be). To be precise, the
; unification is the statement that two terms are the same. For
; example, unification of 1 and 1 is successful -- 1 is indeed the
; same as 1. That doesn't add however to our knowledge of the world. If
; the logic variable X is associated with 1 in the current
; substitution, the unification of X with 2 yields a contradiction
; (the new measurement is not consistent with the previous
; measurements/hypotheses).  Unification of an unbound logic variable
; X and 1 improves our knowledge: the measurement' found that X is
; actually 1.  We record that fact in the new substitution.

; return the new substitution, or #f on contradiction.
(define (unify t1 t2 s)
(let ((t1 (lookup t1 s)) ; find out what t1 actually is given our knowledge s
(t2 (lookup t2 s))); find out what t2 actually is given our knowledge s
(cond
((eq? t1 t2) s)		; t1 and t2 are the same; no new knowledge
((var? t1)		; t1 is an unbound variable
(ext-s t1 t2 s))
((var? t2)		; t2 is an unbound variable
(ext-s t2 t1 s))
((and (pair? t1) (pair? t2)) ; if t1 is a pair, so must be t2
(let ((s (unify (car t1) (car t2) s)))
(and s (unify (cdr t1) (cdr t2) s))))
((equal? t1 t2) s)	; t1 and t2 are really the same values
(else #f))))

; define a bunch of logic variables, for convenience
(define vx (var 'x))
(define vy (var 'y))
(define vz (var 'z))
(define vq (var 'q))

(cout "test-u1" nl
(unify vx vy empty-subst)
nl)
; => ((#(x) . #(y)))

(cout "test-u2" nl
(unify vx 1 (unify vx vy empty-subst))
nl)
; => ((#(y) . 1) (#(x) . #(y)))

(cout "test-u3" nl
(lookup vy (unify vx 1 (unify vx vy empty-subst)))
nl)
; => 1
; when two variables are associated with each other,
; improving our knowledge about one of them improves the knowledge of the
; other

(cout "test-u4" nl
(unify (cons vx vy) (cons vy 1) empty-subst)
nl)
; => ((#(y) . 1) (#(x) . #(y)))
; exactly the same substitution as in test-u2

; Part 3: Logic system
;
; Now we can combine non-deterministic functions (Part 1) and
; the representation of knowledge (Part 2) into a logic system.
; We introduce a 'goal' -- a non-deterministic function that takes
; a substitution and produces 0, 1 or more other substitutions (new
; knowledge). In case the goal produces 0 substitutions, we say that the
; goal failed. We will call any result produced by the goal an 'outcome'.

; The functions 'succeed' and 'fail' defined earlier are obviously
; goals.  The latter is the failing goal. OTH, 'succeed' is the
; trivial successful goal, a tautology that doesn't improve our
; knowledge of the world. We can now add another primitive goal, the
; result of a measurement'.  The quantum-mechanical connotations of
; the measurement' must be obvious by now.

(define (== t1 t2)
(lambda (s)
(cond
((unify t1 t2 s) => succeed)
(else (fail s)))))

; We also need a way to 'run' a goal,
; to see what knowledge we can obtain starting from sheer ignorance
(define (run g) (g empty-subst))

; We can build more complex goals using lambda-abstractions and previously
; defined combinators, conj and disj.
; For example, we can define the function choice' such that
; (choice t1 a-list) is a goal that succeeds if t1 is an element of a-list.

(define (choice var lst)
(if (null? lst) fail
(disj
(== var (car lst))
(choice var (cdr lst)))))

(cout "test choice 1" nl
(run (choice 2 '(1 2 3)))
nl)
; => (()) success

(cout "test choice 2" nl
(run (choice 10 '(1 2 3)))
nl)
; => ()
; empty list of outcomes: 10 is not a member of '(1 2 3)

(cout "test choice 3" nl
(run (choice vx '(1 2 3)))
nl)
; => (((#(x) . 1)) ((#(x) . 2)) ((#(x) . 3)))
; three outcomes

; The name choice' should evoke The Axiom of Choice...

; Now we can write a very primitive program: find an element that is
; common in two lists:

(define (common-el l1 l2)
(conj
(choice vx l1)
(choice vx l2)))

(cout "common-el-1" nl
(run (common-el '(1 2 3) '(3 4 5)))
nl)
; => (((#(x) . 3)))

(cout "common-el-2" nl
(run (common-el '(1 2 3) '(3 4 1 7)))
nl)
; => (((#(x) . 1)) ((#(x) . 3)))
; two elements are in common

(cout "common-el-3" nl
(run (common-el '(11 2 3) '(13 4 1 7)))
nl)
; => ()
; nothing in common

; Let us do something a bit more complex

(define (conso a b l) (== (cons a b) l))

; (conso a b l) is a goal that succeeds if in the current state
; of the world, (cons a b) is the same as l.
; That may, at first, sound like the meaning of cons. However, the
; declarative formulation is more powerful, because a, b, or l might
; be logic variables.
;
; By running the goal which includes logic variables we are
; essentially asking the question what the state of the world should
; be so that (cons a b) could be the same as l.

(cout "conso-1" nl
(run (conso 1 '(2 3) vx))
nl)
; => (((#(x) 1 2 3))) === (((#(x) . (1 2 3))))

(cout "conso-2" nl
(run (conso vx vy (list 1 2 3)))
nl)
; => (((#(y) 2 3) (#(x) . 1)))
; That looks now like 'cons' in reverse. The answer means that
; if we replace vx with 1 and vy with (2 3), then (cons vx vy)
; will be the same as '(1 2 3)

; Terminology: (conso vx vy '(1 2 3)) is a goal (or, to be more precise,
; an expression that evaluates to a goal). By itself, 'conso'
; is a parameterized goal (or, abstraction over a goal):
; conso === (lambda (x y z) (conso x y z))
; We will call such an abstraction 'relation'.

; Let us attempt a more complex relation: appendo
; That is, (appendo l1 l2 l3) holds if the list l3 is the
; concatenation of lists l1 and l2.
; The first attempt:

(define (apppendo l1 l2 l3)
(disj
(conj (== l1 '()) (== l2 l3))    ; [] ++ l == l
(let ((h (var 'h)) (t (var 't))  ; (h:t) ++ l == h : (t ++ l)
(l3p (var 'l3p)))
(conj
(conso h t l1)
(conj
(conso h l3p l3)
(apppendo t l2 l3p))))))

; If we run the following, we get into the infinite loop.
; (cout "t1"
;   (run (apppendo '(1) '(2) vq))
;   nl)

; It is instructive to analyze why. The reason is that
; (apppendo t l2 l3p) is a function application in Scheme,
; and so the (call-by-value) evaluator tries to find its value first,
; before invoking (conso h t l1). But evaluating (apppendo t l2 l3p)
; will again require the evaluation of (apppendo t1 l21 l3p1), etc.
; So, we have to introduce eta-expansion. Now, the recursive
; call to apppendo gets evaluated only when conj applies
; (lambda (s) ((apppendo t l2 l3p) s)) to each result of (conso h l3p l3).
; If the latter yields '() (no results), then appendo will not be
; invoked. Compare that with the situation above, where appendo would
; have been invoked anyway.

(define (apppendo l1 l2 l3)
(conj (== l1 '()) (== l2 l3))    ; [] ++ l == l
(let ((h (var 'h)) (t (var 't))  ; (h:t) ++ l == h : (t ++ l)
(l3p (var 'l3p)))
(conj
(conso h t l1)
(lambda (s)
((conj
(conso h l3p l3)
(lambda (s)
((apppendo t l2 l3p) s))) s))))))

(cout "t1" nl
(run (apppendo '(1) '(2) vq))
nl)
; => (((#(l3p) 2) (#(q) #(h) . #(l3p)) (#(t)) (#(h) . 1)))

; That all appears to work, but the result is kind of ugly;
; and all the eta-expansion spoils the code.

; To hide the eta-expansion (that is, (lambda (s) ...) forms),
; we have to introduce a bit of syntactic sugar:

(define-syntax conj*
(syntax-rules ()
((conj*) succeed)
((conj* g) g)
((conj* g gs ...)
(conj g (lambda (s) ((conj* gs ...) s))))))

; Incidentally, for disj* we can use a regular function
; (because we represent all the values yielded by a non-deterministic
; function as a regular list rather than a lazy list). All branches
; of disj will be evaluated anyway, in our present model.
(define (disj* . gs)
(if (null? gs) fail
(disj (car gs) (apply disj* (cdr gs)))))

; And so we can re-define appendo as follows. It does look
; quite declarative, as the statement of two equations that
; define what list concatenation is.

(define (apppendo l1 l2 l3)
(conj* (== l1 '()) (== l2 l3))   ; [] ++ l == l
(let ((h (var 'h)) (t (var 't))  ; (h:t) ++ l == h : (t ++ l)
(l3p (var 'l3p)))
(conj*
(conso h t l1)
(conso h l3p l3)
(apppendo t l2 l3p)))))

; We also would like to make the result yielded by run more
; pleasant to look at.
; First of all, let us assume that the variable vq (if bound),
; holds the answer to our inquiry. Thus, our new run will try to
; find the value associated with vq in the final substitution.
; However, the found value may itself contain logic variables.
; We would like to replace them, too, with their associated values,

; We define a more diligent version of lookup, which replaces
; variables with their values even if those variables occur deep
; inside a term.

(define (lookup* var s)
(let ((v (lookup var s)))
(cond
((var? v) v)			; if lookup returned var, it is unbound
((pair? v)
(cons (lookup* (car v) s)
(lookup* (cdr v) s)))
(else v))))

; We can now redefine run as

(define (run g)
(map (lambda (s) (lookup* vq s)) (g empty-subst)))

; and we can re-run the test

(cout "t1" nl
(run (apppendo '(1) '(2) vq))
nl)
; => ((1 2))

(cout "t2" nl
(run (apppendo '(1) '(2) '(1)))
nl)
; => ()
; That is, concatenation of '(1) and '(2) is not the same as '(1)

(cout "t3" nl
(run (apppendo '(1 2 3) vq '(1 2 3 4 5)))
nl)
; => ((4 5))

(cout "t4" nl
(run (apppendo vq '(4 5) '(1 2 3 4 5)))
nl)
; => ((1 2 3))

(cout "t5" nl
(run (apppendo vq vx '(1 2 3 4 5)))
nl)
; => (() (1) (1 2) (1 2 3) (1 2 3 4) (1 2 3 4 5))
; All prefixes of '(1 2 3 4 5)

(cout "t6" nl
(run (apppendo vx vq '(1 2 3 4 5)))
nl)
; => ((1 2 3 4 5) (2 3 4 5) (3 4 5) (4 5) (5) ())
; All suffixes of '(1 2 3 4 5)

(cout "t7" nl
(run (let ((x (var 'x)) (y (var 'y)))
(conj* (apppendo x y '(1 2 3 4 5))
(== vq (list x y)))))
nl)
; => ((() (1 2 3 4 5)) ((1) (2 3 4 5)) ((1 2) (3 4 5))
;     ((1 2 3) (4 5)) ((1 2 3 4) (5)) ((1 2 3 4 5) ()))
; All the ways to split (1 2 3 4 5) into two complementary parts

; For more detail, please see The Reasoned Schemer'



### 第25回シェル芸勉強会 Q6 -- UTF-16LE

第25回シェル芸勉強会 Q6 -- UTF-16LE: q6.scm
#!r6rs
;; 第25回シェル芸勉強会 Q6 -- UTF-16LE
;; http://qiita.com/nakataSyunsuke/items/339965853684dd11e755
(import (rnrs)
(rnrs mutable-strings))

(define (transcoded-from-hexstring-port in)
(define temporary (make-string 4))
(let* ((h (get-string-n! in temporary 2 2))
(l (get-string-n! in temporary 0 2)))
(if (or (eof-object? h) (eof-object? l))
(eof-object)
(string->number temporary 16))))
(define cp)
(do ((start start (+ start 1))
(i 0 (+ i 1)))
((or (= i count) (begin (set! cp (read-cp)) (eof-object? cp))) i)
(string-set! str start (integer->char cp))))
(define (close) (close-port in))
(make-custom-textual-input-port "hexstring->string" read! #f #f close))

(define (q6 str)
(get-string-all
(transcoded-from-hexstring-port (open-string-input-port str))))

(display (q6 "b730a730eb30b8820a00"))



### Sagittarius 0.8.0 や Mosh 0.2.7 で意図通りの出力にならない。 Chez 9.4.1 や Ypsilon 0.9.6-update3 では OK

Sagittarius 0.8.0 や Mosh 0.2.7 で意図通りの出力にならない。 Chez 9.4.1 や Ypsilon 0.9.6-update3 では OK: q6.scm
#!r6rs
;; 第25回シェル芸勉強会 Q6 -- UTF-16LE
;; http://qiita.com/nakataSyunsuke/items/339965853684dd11e755
(import (rnrs)
(rnrs mutable-strings))

(define (transcoded-from-hexstring-port in)
(define temporary (make-string 4))
(let* ((h (get-string-n! in temporary 2 2))
(l (get-string-n! in temporary 0 2)))
(if (or (eof-object? h) (eof-object? l))
(eof-object)
(string->number temporary 16))))
(do ((start start (+ start 1))
(i 0 (+ i 1)))
((or (= i count) (eof-object? cp)) i)
(string-set! str start (integer->char cp))))
(define (close) (close-port in))
(make-custom-textual-input-port "hexstring->string" read! #f #f close))

(define (q6 str)
(get-string-all
(transcoded-from-hexstring-port (open-string-input-port str))))

(display (q6 "b730a730eb30b8820a00"))



### metacircular evaluator from sicp

metacircular evaluator from sicp: meta.scm
;; metacircular evaluator from sicp
(define apply-in-underlying-scheme apply)
(define (list-of-values exps env)
(if (no-operands? exps)
'()
(cons (eval (first-operand exps) env)
(list-of-values (rest-operands exps) env))))

(define (eval-if exp env)
(if (true? (eval (if-predicate exp) env))
(eval (if-consequent exp) env)
(eval (if-alternative exp) env)))

(define (eval-sequence exps env)
(cond ((last-exp? exps) (eval (first-exp exps) env))
(else (eval (first-exps) env)
(eval-sequence (rest-exps exps) env))))

(define (eval-assignment exp env)
(set-variable-value! (assignment-variable exp)
(eval (assignment-value exp) env)
env)
'ok)

(define (eval-definition exp env)
(define-variable! (define-variable exp)
(eval (define-value exp) env)
env)
'ok)

(define (self-evaluating? exp)
(or (number? exp) (string? exp)))

(define (variable? exp)
(symbol? exp))

(define (quoted? exp)
(tagged-list? exp 'quote))

(define (tagged-list? exp tag)
(if (pair? exp)
(eq? (car exp) tag)
#f))

(define (assignment? exp)
(tagged-list? exp 'set!))

(define (definition? exp)
(tagged-list? exp 'define))

(define (define-variable exp)

(define (define-value exp)
(cddr exp))))

(define (lambda? exp) (tagged-list? exp 'lambda))
(define (lambda-body exp) (cddr exp))

(define (make-lambda parameters body)
(cons 'lambda (cons parameters body)))

(define (if? exp) (tagged-list? exp 'if))
(define (if-alternative exp)
(if (not (null? (cdddr exp)))
'false))

(define (make-if prediciate consequent alternative)
(list 'if predicate consequent alternative))

(define (begin? exp) (tagged-list? exp 'begin))
(define (begin-actions exp) (cdr exp))
(define (last-exp? seq) (null? (cdr seq)))
(define (first-exp seq) (car seq))
(define (rest-exp seq) (cdr seq))

(define (sequence->exp seq)
(cons ((null? seq) seq)
((last-exp? seq) (first-exp seq))
(else (make-begin seq))))

(define (make-begin seq) (cons 'begin seq))

(define (application? exp) (pair? exp))
(define (operator exp) (car exp))
(define (operands exp) (cdr exp))
(define (no-operands? ops) (null? ops))
(define (first-operand ops) (car ops))
(define (rest-operands ops) (cdr ops))

(define (cond? exp) (tagged-list? exp 'cond))
(define (cond-clauses exp) (cdr exp))
(define (cond-else-clause? clause)
(eq? (cond-predicate clause) 'else))
(define (cond-predicate clause) (car clause))
(define (cond-actions clause) (cdr clause))
(define (cond->if exp) (expand-clauses (cond-clauses exp)))
(define (expand-clauses clauses)
(if (null? clauses)
'false
(let ((first (car clauses))
(rest (cdr clauses)))
(if (cond-else-clause? first)
(if (null? rest)
(sequence->exp (cond-actions first))
(error ("ELSE clause isn't last -- COND->IF" clauses)))
(make-if (cond-predicate first)
(sequence->exp (cond-actions first))
(expand-clauses rest))))))

(define (true? x)
(not (false? x)))

(define (false? x)
(eq? x #f))

(define (make-procedure parameters body env)
(list 'procedure parameters body env))

(define (compound-procedure? p)
(tagged-list? p 'procedure))

(define (enclosing-environment env) (cdr env))
(define (first-frame env) (car env))

(define the-empty-environment '())

(define (make-frame variables values)
(cons variables values))

(define (frame-variables frame) (car frame))
(define (frame-values frame) (cdr frame))

(set-car! frame (cons var (car frame)))
(set-cdr! frame (cons val (cdr frame))))

(define (extend-environment vars vals base-env)
(if (= (length vars) (length vals))
(cons (make-frame vars vals) base-env)
(if (< (length vars) (length vals))
(error "Too many arguments supplied" vars vals)
(error "Too few arguments supplied" vars vals))))

(define (lookup-variable-value var env)
(define (env-loop env)
(define (scan vars vals)
(cond ((null? vars)
(env-loop (enclosing-environment env)))
((eq? var (car vars))
(car vals))
(else (scan (cdr vars) (cdr vals)))))
(if (eq? env the-empty-environment)
(error "Unbound variable" var)
(let ((frame (first-frame env)))
(scan (frame-variables frame)
(frame-values frame)))))
(env-loop env))

(define (set-variable-value! var env)
(define (env-loop env)
(define (scan vars vals)
(cond ((null? vars)
(env-loop (enclosing-environment env)))
((eq? var (car vars))
(set-car! vals val))
(else (scan (cdr vars) (cdr vals)))))
(if (eq? env the-empty-environment)
(error "Unbound variable -- SET!" var)
(let ((frame (first-frame env)))
(scan (frame-variables frame)
(frame-values frame)))))
(env-loop env))

(define (define-variable! var val env)
(let ((frame (first-frame env)))
(define (scan vars vals)
(cond ((null? vars)
((eq? var (car vars))
(set-car! vals val))
(else (scan (cdr vars) (cdr vals)))))
(scan (frame-variables frame)
(frame-values frame))))

(define (eval exp env)
(cond ((self-evaluating? exp) exp)
((variable? exp) (lookup-variable-value exp env))
((quoted? exp) (text-of-quotation exp))
((assignment? exp) (eval-assignment exp env))
((definition? exp) (eval-definition exp env))
((if? exp) (eval-if exp env))
((lambda? exp)
(make-procedure (lambda-parameters exp)
(lambda-body exp)
env))
((begin? exp)
(eval-sequence (begin-actions exp) env))
((cond? exp)  (eval (cond->if exp) env))
((application? exp)
(apply (eval (operator exp) env)
(list-of-values (operands exp) env)))
(else
(error "Unknown expression type -- EVAL" exp))))

(define (apply procedure arguments)
(cond ((primitive-procedure? procedure)
(apply-primitive-procedure procedure arguments))
((compound-procedure? procedure)
(eval-sequence
(procedure-body procedure)
(extend-environment
(procedure-parameters procedure)
arguments
(procedure-environment procedure))))
(else
(error "Unknown procedure type -- APPLY" procedure))))

(define (setup-environment)
(let ((initial-env
(extend-environment (primitive-procedure-names)
(primitive-procedure-objects)
the-empty-environment)))
(define-variable! 'true #t initial-env)
(define-variable! 'false #f initial-env)
initial-env))

(define (primitive-procedure? proc) (tagged-list? proc 'primitive))

(define primitive-procedures
(list (list 'car car)
(list 'cdr cdr)
(list 'cons cons)
(list 'null? null?)
(list '+ +)
(list '- -)
(list '* *)
(list '/ /)
(list 'p print)
(list 'list list)))

(define (primitive-procedure-names)
(map car primitive-procedures))

(define (primitive-procedure-objects)
(map (lambda (p) (list 'primitive (cadr p)))
primitive-procedures))

(define (apply-primitive-procedure proc args)
(apply-in-underlying-scheme
(primitive-implementation proc) args))

(define input-prompt "::> ")

(define (driver-loop)
(prompt-for-input input-prompt)
(let ((output (eval input the-global-environment)))
(announce-output)
(user-print output)))
(driver-loop))

(define (prompt-for-input string)
(newline) (newline) (display string))

(define (announce-output)
(newline) (newline))

(define (user-print object)
(if (compound-procedure? object)
(display (list 'compound-procedure
(procedure-parameters object)
(procedure-body object)
'<procedure-env>))
(display object)))

(define the-global-environment (setup-environment))
(driver-loop)



### Simple LRU implementation in Scheme

Simple LRU implementation in Scheme: lru.scm
(define (make-lru size)
(define cnt 0)
(define fl '())
(define ht (make-hash-table))
(define (refresh-fl i)
(set! fl (cons i (filter (lambda (x) (not (= x i))) fl))))
(lambda (cmd . i/v)
(case cmd
((get)
(refresh-fl (car i/v))
(hash-ref ht (car i/v) "no"))
((set)
(display fl) (newline)
(if (= cnt size)
(let ((i (list-ref fl (1- cnt))))
(hash-set! ht i (car i/v))
(refresh-fl i))
(begin
(set! fl (cons cnt fl))
(hash-set! ht cnt (car i/v))
(set! cnt (1+ cnt))))
(hash-map->list cons ht))
((cnt) cnt)
((fl) fl))))



### Functional programming exercises/examples in Scheme

Functional programming exercises/examples in Scheme: recursion_examples.scm
;; fact -- Returns the factorial of a given positive integer.
(define fact
(lambda (n)
(if (eq? n 0) 1 (* n (fact (- n 1))))))

;; list-length - return length of a list.
(define list-length
(lambda (L)
(if (null? L)
0
(+ 1 (list-length (cdr L))))))

;; fact with helper, tail recursion, and accumulator
(define factacc
(lambda (n)
(factacc* n 1)))

(define factacc*
(lambda (n acc)
(cond
[(eq? n 1) acc]
[else (factacc* (- n 1) (* acc n))])))

;; Exercise
;; Write a function (reverse ls) which takes a list ls and returns the
;; list in reverse order.
;; E.g., (reverse '()) => (),  (reverse '(1 2 3 4)) => (4 3 2 1)

;; Question: What is the running time of your function?

;; Running time = O(n^2), assuming append runs in O(n) time.
(define reverse
(lambda (ls)
(cond
[(null? ls) '()]
[tail (cdr ls)])

;; Question: Can we do better? Yes!

;; Running time = O(n) using accumulator
(define reverse-acc
(lambda (ls)
(reverse-acc* ls '())))

(define reverse-acc*
(lambda (ls acc)
(cond
[(null? ls) acc]
[else
[tail (cdr ls)])

;; Tracing is a powerful debugging tool
(trace reverse reverse-acc reverse-acc*)

;; reverse is _not_ tail recursive
;; ------------------------
;; > (reverse '(1 2 3))
;; |(reverse (1 2 3))
;; | (reverse (2 3))
;; | |(reverse (3))
;; | | (reverse ())
;; | | ()
;; | |(3)
;; | (3 2)
;; |(3 2 1)
;; (3 2 1)
;; ------------------------

;; reverse-acc is tail recursive
;; -------------------------------
;; > (reverse-acc '(1 2 3))
;; |(reverse-acc (1 2 3))
;; |(reverse-acc* (1 2 3) ())
;; |(reverse-acc* (2 3) (1))
;; |(reverse-acc* (3) (2 1))
;; |(reverse-acc* () (3 2 1))
;; |(3 2 1)
;; (3 2 1)
;; ------------------------------

;; Exercise
;; Write a function (fib n) computing the nth Fibonacci number
;; E.g., (fib 0) => 0, (fib 1) => 1, (fib 2) => 1, (fib 5) => 5 ...

;; Question: What is the running time of your function

;; Fibonacci - brute force - O(2^n)
(define fib
(lambda (n)
(cond
[(eq? 0 n) 0]
[(eq? 1 n) 1]
[else (+ (fib (- n 1)) (fib (- n 2)))])))

;; Question: How can we do better?

;; Fibonacci - tail recursion - O(n)
(define fib-tail
(lambda (n)
(cond
[(eq? 1 n) 0]
[else (fib-tail* 0 1 2 n)])))

(define fib-tail*
(lambda (f_i-1 f_i i n)
(cond
[(eq? i n) f_i]
[else (fib-tail* f_i (+ f_i-1 f_i) (+ i 1) n)])))

;; Exercise - Dual recursion
;; What do the following pair of function compute?
;; And what is their running time?
(define even?
(lambda (x)
(cond
[(eq? x 0) #t]
[else (odd? (- x 1))])))

(define odd?
(lambda (x)
(cond
[(eq? x 0) #f]
[else (even? (- x 1))])))

(trace odd? even?)

;; You can define "private" recursive functions using the syntactic
;; form letrec.  Its just like the syntactic form let, but allows you
;; to define variables storing recursive functions.

(define even
(lambda (x)
(letrec
([_even
(lambda (x)
(cond
[(eq? x 0) #t]
[else (_odd (- x 1))]))]
[_odd
(lambda (x)
(cond
[(eq? x 0) #f]
[else (_even (- x 1))]))])
(_even x))))

;; Higher-Order Functions (HOF)
;;
;;   Functions are "first-class values" in Scheme.  It's one of the
;;   most defining features of functional languages.  First-class
;;   values are values that can be passed into functions and returned
;;   from functions.

;;   Higher-order functions are functions which take as an argument
;;   and / or return a value which is a function.

;;   For example, the map function from Exercise 29 of HW 1 is a HOF,
;;   because it takes a function as an input.

(define map
(lambda (f ls)
(cond
[(null? ls) '()]
[else (cons (f (car ls)) (map f (cdr ls)))]
)))

(define ls+1
(lambda (ls)
(map (lambda (x) (+ x 1)) ls)))

;;  Here's an example of another HOF which is usage for writing
;;  tail-recursive accumulating functions. It is called "folding" or
;;  "reducing" in other functional languages.

(define fold-left
(lambda (f acc ls)
(cond
[(null? ls) acc]
[else (fold-left f (f acc (car ls)) (cdr ls))])))

;; An example usage:

(define list-length
(lambda (ls)
(fold-left (lambda (acc head) (+ acc 1)) 0 ls)))

(define reverse
(lambda (ls)

;; Here are some examples from HW1 implemented using map and fold-left.

(define member
(lambda (e ls)

(define append
(lambda (ls1 ls2)

(define flatten
(lambda (lls)

(define map
(lambda (fn ls)

(define filter
(lambda (p? ls)

(define counts
(lambda (p? ls)
(fold-left (lambda (acc head) (if (p? head) (+ acc 1) acc)) 0 ls)))

(define insert
(lambda (num ls)
(append

(define sort ;; insertion sort
(lambda (ls)

;;  The following is an example of a HOF function which returns a
;;  function.

(define poly
(lambda (n)
(cond
[(= n 0) (lambda (x) 1)]
[else (lambda (x) (+ (* n (expt x n)) ((poly (- n 1)) x)))])))

;; Exercises
;; - What does (poly 1) return?
;; - What does (poly 3) return?
;; - What does ((poly 3) 2) return?



### Lambda!

Lambda!: lambda.scm
((lambda (lambda) (lambda lambda)) (lambda (lambda) lambda))



### Play pattern for midi instruments

Play pattern for midi instruments: mplayp.scm


;;;;;;;;;;;;;;; On Beat ;;;;;;;;;;;;;;;;;;;;;

(define-macro (onbeat? b of t . f)
(if (null? f)
(if (= (modulo beat ,of) (- ,b 1))
,t)
(if (= (modulo beat ,of) (- ,b 1))
,t ,(car f))))

;;;;;;;;;;;;;;;; Pattern Player for MIDI Instruments ;;;;;;;;;;;;;;

(define mplayp_play_list
(let ((lst_idx (range 0 1000)))
(lambda (beat dur pclas inst vols durs channel lst mod_diff step offset poffset args)
(let ((duration 0) (volume 0)
(phase 0))
(for-each (lambda (x idx t)
(if (symbol? x) (set! x (eval x)))
(if (list? durs)
(if (and (symbol? (car durs))
(defined? (car durs))
(or (closure? (eval (car durs)))
(procedure? (eval (car durs)))
(macro? (eval (car durs)))))
(set! duration durs)
(if (= (length durs) (length lst))
(set! duration (list-ref durs idx))
(set! duration step)))
(set! duration durs))
(if (list? vols)
(if (and (symbol? (car vols))
(defined? (car vols))
(or (closure? (eval (car vols)))
(procedure? (eval (car vols)))
(macro? (eval (car vols)))))
(set! volume vols)
(if (= (length vols) (length lst))
(set! volume (list-ref vols idx))
(set! volume 80)))
(set! volume vols))
(if (list? x)
(mplayp_play_list beat dur pclas inst volume
duration channel x mod_diff (/ step (length lst)) (+ t offset) poffset args)
(if (> x 0)
(begin
(set! phase (+ mod_diff t offset))
(eval
(mplay ,phase ;(+ mod_diff t offset)
,inst
,(pc:quantize (+ x poffset) pclas)
,volume
,duration
,channel
,@args))))))
lst
lst_idx
(range 0 step (/ step (length lst))))))))

(define mplayp_f
(lambda (beat dur . args)
(let ((pclas '(0 1 2 3 4 5 6 7 8 9 10 11))
(offset 0)
(poffset 0)
(inst '())
(data '())
(vols '())
(durs '())
(channel 0)
(datal 0)
(cycle 0)
(step 0))
;; check for quantizer list
(if (list? (car args))
(begin (set! pclas (car args))
(set! args (cdr args))))
;; now cycle
(if (or (closure? (car args)) (cptr? (car args)))
(set! cycle dur)
(begin
(set! cycle (car args))
(set! args (cdr args))))
;; if no instrument must be an offset
;(if (not (closure? (car args)))
(if (not (or (closure? (car args)) (cptr? (car args))))
(begin (set! offset (car args))
(set! args (cdr args))))
;; now instrument (which should be a closure!)
(set! inst (car args))
(set! args (cdr args))
;; if not pitch list must be offset
(if (not (list? (car args)))
(begin (set! poffset (car args))
(set! args (cdr args))))
;; now must be pitch list
(set! data (car args))
(set! args (cdr args))
(set! datal (length data))
(set! vols (car args))
(set! args (cdr args))
(set! durs (car args))
(set! args (cdr args))
(set! channel (car args))
(set! args (cdr args))
(set! step (/ cycle datal))
(let ((local_beat (modulo beat cycle))
(mod_diff 0)
(volume vols)
(phase 0.0)
(duration durs)
(pitch 0))
(dotimes (i (* 2 datal))
(set! mod_diff (- (* i step) local_beat))
(set! pitch (list-ref data (modulo i datal)))
(if (symbol? pitch) (set! pitch (eval pitch)))
(if (list? durs)
(if (and (symbol? (car durs))
(defined? (car durs))
(or (closure? (eval (car durs)))
(procedure? (eval (car durs)))
(macro? (eval (car durs)))))
(set! duration durs)
(if (= (length durs) datal)
(set! duration (list-ref durs (modulo i datal)))
(set! duration step))))
(if (list? vols)
(if (and (symbol? (car vols))
(defined? (car vols))
(or (closure? (eval (car vols)))
(procedure? (eval (car vols)))
(macro? (eval (car vols)))))
(set! volume vols)
(if (= (length vols) datal)
(set! volume (list-ref vols (modulo i datal)))
(set! volume 80))))
(if (list? pitch)
(begin
(if (and (>= mod_diff 0)
(< mod_diff dur)
(not (null? pitch)))
(mplayp_play_list beat dur pclas inst volume duration channel pitch mod_diff step offset poffset args)))
(begin
(set! phase (+ mod_diff offset))
(if (and (>= mod_diff 0)
(< mod_diff dur)
(> pitch 0))
(eval (mplay ,phase ;(+ mod_diff offset)
,inst
,(pc:quantize (+ pitch poffset) pclas)
,volume
,duration
,channel
,@args))
(begin #f)))))))))

;; this is what you *actually* call
(define-macro (mplayp . args)
(mplayp_f beat dur ,@args))

; remember
; BEAT and DUR arguments must be defined for mplayp to work

"""

1) Checking for a CPTR symbol as well as a CLOSURE:

(println mididevice)  ;;#<CPTR: 0x7fc32ac67ce0>
(println synth) ;; #<<CLOSURE 0x118d20c80>

So this
(if (not (closure? (car args)))
(begin (set! offset (car args))
(set! args (cdr args))))

Becomes
(if (not (or (closure? (car args)) (cptr? (car args))))
(begin (set! offset (car args))
(set! args (cdr args))))

2) Adding the channel parameter in various places eg

(mplayp_play_list beat dur pclas inst volume duration channel pitch mod_diff step offset poffset args)))

EXAMPLE

;; SETUP
(pm_print_devices)
(define mididevice (pm_create_output_stream 4)) ; eg Device 4
(play-midi-note (now) mididevice (random 36 42) 90 44100 0)

;; TESTING
(define loop
(lambda (beat dur)
(mplayp 2 mididevice -24 '(80 72 70 (75 77)) 80 dur 0)
(mplayp 4 mididevice '(80 72 70 (75 77)) 80 dur 1)
(mplayp 8 mididevice '(80 72 70 (75 77)) 80 dur 2)
(callback (*metro* (+ beat (* 1/2 dur))) 'loop (+ beat dur) dur)))

(loop (*metro* 'get-beat 1) 1/4)

"""

;
;We generally encourage the DIY approach when it comes to compositional tools in Extempore, but here's a little pattern player that I thought some of you might find useful. It wont be added to mainline, so stick it in your personal lib somewhere.  I've included a link to a brief 5min video - just the absolute basics.
;
;It's quite powerful but will probably take you some time to get your head around.  Particularly with the rates of change.  onbeat? is something to keep in mind - I've also added that macro in case you don't have something similar. (onbeat? 1 8 (println "HI")).  On beat 1 of 8 print "HI". (onbeat? 2 3 (println "HI")) etc..
;
;The basic form of the pattern player is (where <> are optional)
;
;(playp <pitch-class> pattern-length instrument <pitch-offset> pitch-pattern volume duration . args)
;
;A pitch pattern is just a list.  As it should be ;)  As a pattern is *just* a list, you can apply any transformation to that list (or sublists) that you desire.
;
;The list is evenly divided into the pattern-length, which is specified in beats.  A pattern can contain sub patterns (i.e. sub lists), where a sublist is a pattern that takes the exact duration that it replaces. i.e. '(60 (67 65) 63) with a pattern-length of 3 would result in a rhythm of 1 1/2 1/2 1.  A pattern length of 2 would result in 2/3 1/3 1/3 2/3. etc..
;
;You can optionally provide patterns for volume and duration, but they must match the pitch-pattern.  You can also optionally quote volume and duration - which allows for update rates different from the TR rate.  There is also a 'hidden' phase that can be applied to volume and duration - for use as offsets for functions like cosr rampr etc..   I wont explain any of that further here - ask questions if your interested, and get stuck on something.
;
;Other than that volume and duration behave as with play.  Also 'args' behaves just as it does with play.
;
;What is worth paying attention to is that the pattern runs independently of the temporal recursion rate, but the update rate is obviously tied to the TR rate.   In other words, while the pattern maybe independent of the update rate, everything else you do in the TR is still tied to the TR rate. This is actually quite a useful compositional tool, but might take a little practice to get familiar with.
;
;Here is a *very* cursory video introduction.  Although this example is pitched, the same code obviously works just as well for purely rhythmic material.
;
;https://youtu.be/ARRIVEGROEg
;
;In your own setup use custom definitions for shorter entry - like using (define R repeat) (define Rnd random) (define I invert) (define J jumble) (define Rev reverse) and add pitch definitions (define c4 60) etc..  This will make your patterns much quicker to write and easier to read.  i.e. (c3 (R d3 2) (Rnd c5 c6)).  I went long form in the video for clarity ;)
;
;Cheers,
;Andrew.
;

;https://youtu.be/ARRIVEGROEg



### Basic parsing combinators

Basic parsing combinators: maze-parser.scm
;; The following code uses two function types: parsers and continuations.  The parser function
;; require three arguments: input, continue and backtrack.  The continuation functions
;; require just one argument input.  The argument input is the list of input tokens to parse.
;; The arguments continue and backtrack are continuations.  The continuation continue is
;; followed, when the tried parsing solution up the to current point is correct, which means that it
;; is not sure but it might lead to a overall success.  And backtrack is used, if a missmatch has
;; been found, which means that an alternative parsing solution must be tried.  The process is
;; similar to finding the way out of a maze.

;; Throw an error, if the assertion fails.
(define-syntax assert
(syntax-rules (=>)
((assert x => y)
(if (not (equal? x y))
(error "Assertion failed.")))))

;; This are the most basic parsers, which always succeed and always fail.
(define success (lambda _ #t))
(define failure (lambda _ #f))

;; This are debugging parsers, which display the remaining input.
(define success* (lambda (input . _) (write input) (newline) #t))
(define failure* (lambda (input . _) (write input) (newline) #f))

;; Make a character tester function.
(define (char= character)
(lambda (input)
(and (pair? input)
(char=? character (car input)))))

;; Make parsers, which match a predicate.
(define (const match?)
(lambda (input continue backtrack)
(if (match? input)
(continue (cdr input))
(backtrack input))))

;; Make some character parsers.
(define a? (const (char= #\a)))
(define b? (const (char= #\b)))

;; Test some characters.
(assert (a? '(#\a) success failure) => #t)
(assert (a? '(#\b) success* failure*) => #f)
(assert (b? '(#\a) success failure) => #f)
(assert (b? '(#\b) success failure) => #t)

;; Make a seqence of two parsers.
(define (sequence p q)
(lambda (input-p continue backtrack)
(p input-p
(lambda (input-q)
(q input-q
continue
(lambda _ (backtrack input-p))))     ; When backtrack of q gets called, this means, that
; q has failed.  If q has failed the sequence of p
; and q also fails and backtrack must continue with
; the input of p throwing away any fallacious
; success of p.
backtrack)))

;; Make some sequence parsers.
(define a+a? (sequence a? a?))
(define a+b? (sequence a? b?))

;; Test the sequences.
(assert (a+a? '(#\a #\a) success* failure*) => #t)
(assert (a+a? '(#\a #\b) success* failure*) => #f)
(assert (a+b? '(#\a #\b) success* failure*) => #t)

;; Make an alternation of two parsers.
(define (alternation p q)
(lambda (input continue backtrack)
(p input
continue
(lambda _
(q input
continue
backtrack)))))

;; Make a single alternation and test it.
(define a-b? (alternation a? b?))
(assert (a-b? '(#\a) success* failure*) => #t)
(assert (a-b? '(#\b) success* failure*) => #t)
(assert (a-b? '(#\c) success* failure*) => #f)

;; Make a sequence containing an alternation and test it.
(define a+a-b? (sequence a? (alternation a? b?)))
(assert (a+a-b? '(#\a #\a) success* failure*) => #t)
(assert (a+a-b? '(#\a #\b) success* failure*) => #t)
(assert (a+a-b? '(#\b #\a) success* failure*) => #f)
(assert (a+a-b? '(#\a #\c) success* failure*) => #f)

;; Make an alternation of two sequences sharing the same beginning and test it.
(define a+a-a+b? (alternation a+a? a+b?))
(assert (a+a-a+b? '(#\a #\b) success* failure*) => #t)
(assert (a+a-a+b? '(#\a #\c) success* failure*) => #f)

`
• Public Snippets
• Channels Snippets