working on it ...

Filters

snippets
536
followers
4
Published by snip2code

Scheme

This channel collects useful snippets for Scheme language
Sort by

Found 536 snippets

    public by cuhardware modified Jan 6, 2016  165  0  4  0

    Loop 4 times with condition

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

    external by charles-l modified Thursday at 11:42:46 PM  1  0  1  0

    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 (text-of-quotation exp) (cadr exp))
    
    (define (tagged-list? exp tag)
      (if (pair? exp)
        (eq? (car exp) tag)
        #f))
    
    (define (assignment? exp)
      (tagged-list? exp 'set!))
    
    (define (assignment-variable exp) (cadr exp))
    (define (assignment-value exp) (caddr exp))
    
    (define (definition? exp)
      (tagged-list? exp 'define))
    
    (define (define-variable exp)
      (if (symbol? (cadr exp))
        (cadr exp)
        (caadr exp)))
    
    (define (define-value exp)
      (if (symbol? (cadr exp))
        (caddr exp)
        (make-lambda (cdadr exp)
                     (cddr exp))))
    
    (define (lambda? exp) (tagged-list? exp 'lambda))
    (define (lambda-parameters exp) (cadr exp))
    (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-predicate exp) (cadr exp))
    (define (if-consequent exp) (caddr exp))
    (define (if-alternative exp)
      (if (not (null? (cdddr exp)))
        (cadddr 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 (procedure-parameters p) (cadr p))
    (define (procedure-body p) (caddr p))
    (define (procedure-environment p) (cadddr p))
    
    (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))
    
    (define (add-binding-to-frame! var val 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)
                 (add-binding-to-frame! var val frame))
                ((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-implementation proc) (cadr proc))
    
    (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 ((input (read)))
        (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)
    
    
    

    external by Mu Lei modified Jan 14, 2017  1  0  1  0

    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))))
    
    

    external by Aidan Pieper modified Jan 14, 2017  1  0  1  0

    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) '()]
         [else (let ([head (car ls)]
    		 [tail (cdr ls)])
    	     (append (reverse tail) (list head)))])))
    
    ;; 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
          (let ([head (car ls)]
    	    [tail (cdr ls)])
    	(reverse-acc* tail (cons head acc)))])))
    	    
    
    ;; 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)
        (fold-left (lambda (acc head) (cons head acc)) '() ls)))
    
    ;; Here are some examples from HW1 implemented using map and fold-left.
    
    (define member
      (lambda (e ls)
        (fold-left (lambda (acc head) (or (equal? e head) acc)) #f ls))) 
    
    (define append
      (lambda (ls1 ls2)
        (fold-left (lambda (acc head) (cons head acc)) ls2 (reverse ls1))))
    
    (define flatten
      (lambda (lls)
        (fold-left (lambda (acc head) (append acc head)) '() lls)))
    
    (define map
      (lambda (fn ls)
        (fold-left (lambda (acc head) (cons (fn head) acc)) '() (reverse ls))))
    
    (define filter
      (lambda (p? ls)
        (fold-left (lambda (acc head) (if (p? head) (cons head acc) acc)) '() (reverse 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
         (filter (lambda (head) (>= num head)) ls)
         (cons num (filter (lambda (head) (< num head)) ls)))))
    
    (define sort ;; insertion sort
      (lambda (ls)
        (fold-left (lambda (acc head) (insert head acc)) '() 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? 
    
    
    

    external by Aidan Pieper modified Jan 14, 2017  1  0  1  0

    Lambda!

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

    external by Michele Pasin modified Jan 6, 2017  1  0  1  0

    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
    
    
    """
    Updates:
    
    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)
    
    """
    
    
    
    
    
    ;; from Andrew https://mail.google.com/mail/u/0/#label/LSTs-AlgoMusic%2FLST-extempore/158e2c894316d1b9
    
    ;
    ;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
    
    
    

    external by ceving modified Jan 6, 2017  1  0  1  0

    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)
    
    
    

    external by Ismael-VC modified Jan 3, 2017  1  0  1  0

    Docstrings documentation functions for FemtoLisp.

    Docstrings documentation functions for FemtoLisp.: femto-docs.scm
    ;;;; FemtoLisp Documentation System
    
    
    (define (docstring f)
        "
            (docstring f)
    
        Retrieve and display function `f` docstring.
    
        # Usage
    
        ```
        > (docstring help)
        \"\n        (help f)\n\n    Displays documentation for function `f`.\n\n    # Usage\n\n    ```\n    > (help docstring)\n\n           (docstring f)\n        Retrieve and display function `f` docstring.\n\n    #t\n\n    > (help princ)\n\n        No documentation found for `princ`.\n\n    #t\n\n    > (help 'foo)\n    type error: function:name: expected function, got foo\n    #0 (help foo)\n    ```\n    \"
    
        > (docstring princ)
        \"\"
    
        > (docstring 'foo)
        type error: function:vals: expected function, got foo
        #0 (docstring foo)
        ```
        "
        (let* ((function-values (function:vals f))
               (first-value     (aref function-values 0))
               (doc-string      (if (string? first-value)
                                    first-value
                                    "")))
    
              doc-string))
    
    
    (define (help f)
        "
            (help f)
    
        Displays documentation for function `f`.
    
        # Usage
    
        ```
        > (help docstring)
    
                (docstring f)
    
            Retrieve and display function `f` docstring.
    
            # Usage
    
            ```
            > (docstring help)
            \"
                (help f)
    
            Displays documentation for function `f`.
            \"
    
            > (docstring princ)
            \"\"
    
            > (docstring 'foo)
            type error: function:vals: expected function, got foo
            #0 (docstring foo)
            ```
    
        #t
    
        > (help princ)
    
            No documentation found for `princ`.
    
        #t
    
        > (help 'foo)
        type error: function:name: expected function, got foo
        #0 (help foo)
        ```
        "
        (let* ((function-name     (function:name f))
               (doc-string        (docstring f))
               (docstring-message (if (eq? doc-string "")
                   (string "\n    No documentation found for `"
                                  function-name
                                  "`.\n\n")
                   (string doc-string "\n"))))
    
              (with-output-to *output-stream* (princ docstring-message))))
    
    
    

    external by phasetr modified Dec 29, 2016  1  0  1  0

    素数夜曲を読んでいて次のような Scheme のコードが出てきた.

    素数夜曲を読んでいて次のような Scheme のコードが出てきた.: gistfile1.scm
    (write (= 1 2 3 4 5 6)) ; => #f
    (write (= 1 1 1)) ; => #t
    (write (= 1 1 1 2)) ; => #f
    
    (write (< 1 2 2 3)) ; => #f
    (write (< 1 2 3 4)) ; => #t
    
    

    external by jweinst1 modified Dec 7, 2016  2  0  1  0

    implements a dictionary in scheme

    implements a dictionary in scheme: dict.scm
    ;Implementing a Dictionary in Scheme;
    ;keys must be numbers;
    
    ;Constructor Method;
    (define (dict k v)
      (list (cons k v))
    )
    
    ;Takes a Scheme list and makes it into a dictionary;
    ;(lstdict (list 3 4 5 6)) => ((3 . 4) (4 . 5) (5 . 6));
    (define (lstdict lst)
      (cond
        ((null? (cdr lst)) ())
        (else 
              (cons (cons (car lst) (cadr lst)) (lstdict (cdr lst))))
      )
    )
    
    ;Get Method;
    ;Returns nothing if key not in dictionary;
    (define (get d key)
      (cond
        ((null? d) #f)
        ((= key (caar d)) (cdar d))
        (else (get (cdr d) key))
      )
    )
    
    ;in method;
    ;checks if a key exists in the dictionary;
    (define (contains d key)
      (cond
        ((null? d) #f)
        ((= key (caar d)) #t)
        (else (get (cdr d) key))
      )
    )
      
    
    ;Adds a Key Value Pair;
    ;(add ccc 8 90) => ((8 . 90) (3 . 6));
    (define (add d k v)
      (cons (cons k v) d)
    )
    
    
    • Public Snippets
    • Channels Snippets