working on it ...

Filters

snippets
599
followers
6
Published by snip2code

Scheme

This channel collects useful snippets for Scheme language
Sort by

Found 599 snippets

    public by snip2code modified Aug 13, 2017  535  3  4  0

    First Snippet: How to play with Snip2Code

    This is the first example of a snippet: - the title represents in few words which is the exact issue the snippet resolves; it can be something like the name of a method; - the description (this field) is an optional field where you can add interesting information regarding the snippet; something like the comment on the head of a method; - the c
    /* place here the actual content of your snippet. 
       It should be code or pseudo-code. 
       The less dependencies from external stuff, the better! */

    public by cuhardware modified Jan 6, 2016  1985  0  5  0

    Loop 4 times with condition

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

    external by Yoxem modified Feb 19, 2018  11  0  1  0

    A demo of continuation-pass-style (CPS) by finding the n-th number of fibonacci series with R5RS Scheme.

    A demo of continuation-pass-style (CPS) by finding the n-th number of fibonacci series with R5RS Scheme.: cps.scm
    ;; a demo of continuation-pass-style by finding the n-th number of fibonacci series.
    ;; works in R5RS scheme
    
    (define +&
      (lambda (a b y)
          (y (+ a b)
    )))
    
    (define <&
      (lambda (a b y)
          (y (< a b)
    )))
    
    (define =&
      (lambda (a b y)
          (y (= a b)
    )))
    
    (define (fib& n y)
    (<& n 2 (lambda (nlt2)
              (if nlt2
                 (y 1)
                 (fib-iter& n 2 1 1 y)
    ))))
    
    (define (fib-iter& n i fib_n-1 fib_n-2 y)
      (+& fib_n-1 fib_n-2 (lambda (fib-n)
                            (let
                                ((fib_n fib-n))
                                (=& n i (lambda (neqi)
                                          (if neqi
                                             (y fib_n)
                                             (+& i 1 (lambda (i+1)
                                                       (fib-iter& n i+1 fib_n fib_n-1 y)
    )))))))))
    
    (fib& 1 (lambda(x) x))
    (fib& 10 (lambda(x) x))
    
    

    external by fare modified Feb 17, 2018  12  0  1  0

    case-lambda works in the interpreter, only accepts the base case in the compiler

    case-lambda works in the interpreter, only accepts the base case in the compiler: case-lambda-bug.ss
    ;; works with Gerbil v0.12-DEV-1315-g5902327 on Gambit v4.8.8-434-g490f0a7d on nixpkgs 867d3f9 (gcc 7.2.0)
    ;; fails with Gerbil v0.12-DEV-1404-g0a266db on Gambit v4.8.8-435-gd1991ba7 on nixpkgs dafdaa9 (gcc 7.3.0)
    
    package: bug
    
    (export #t)
    (import :clan/utils/assert)
    
    (def foo (case-lambda (() 0) ((x) 1) ((x y) 2) ((x y z . t) (+ 3 (length t)))))
    
    (def (test-foo)
      (assert-equal! (foo) 0)
      (assert-equal! (foo 0) 1)
      (assert-equal! (foo 0 1) 2)
      (assert-equal! (foo 0 1 2) 3)
      (assert-equal! (foo 0 1 2 3) 4))
    
    
    

    external by Yoxem modified Feb 5, 2018  13  0  1  0

    A simple example of call/cc (call-with-current-continuation)

    A simple example of call/cc (call-with-current-continuation): call-cc.scm
    (define (g x)
      (display "萬歲")
      (cos (x 18))(x 20)
      (display "ura")
      72
    )
    (call-with-current-continuation g)
    ;; print 萬歲18
     (g cos)
    ;; print 萬歲ura72
    (define
      (h x)
      (display "萬歲")
      (cos (x 18))
      (x 20)
      (display "ura")
      72
      (+ 2 2)
    )
    (h cos)
    ;;print 萬歲ura4
    (define (j x)
      (display "萬歲")(cos (x 18))(x 20)
      (display "ura")
      72
      (call-with-current-continuation j))
    (j cos)
    ;; print 萬歲ura萬歲18
    
    

    external by vyzo modified Feb 2, 2018  12  0  1  0

    still object accounting

    still object accounting: still-objects.scm
    (c-declare #<<END-C
    // these are defined in gambit/lib/mem.c
    #define ___PSTATE_MEM(var) ___ps->mem.var
    #define still_objs ___PSTATE_MEM(still_objs_)
    #define ___STILL_LINK_OFS 0
    #define ___STILL_REFCOUNT_OFS 1
    #define ___STILL_BODY_OFS 6
    #define ___STILL_HAND_OFS ___STILL_BODY_OFS
    END-C
    )
    
    (define count-still-objects
      (c-lambda () int #<<END-C
    int count = 0;
    ___WORD *base = ___CAST(___WORD*,still_objs);
    while (base != 0)
    {
     count++;
     base = ___CAST(___WORD*,base[___STILL_LINK_OFS]);
    }
    ___return(count);
    END-C
    ))
    
    (define count-still-objects/refcount
      (c-lambda () int #<<END-C
    int count = 0;
    ___WORD *base = ___CAST(___WORD*,still_objs);
    while (base != 0)
    {
     if (base[___STILL_REFCOUNT_OFS])
      {
       count++;
      }
     base = ___CAST(___WORD*,base[___STILL_LINK_OFS]);
    }
    ___return(count);
    END-C
    ))
    
    (define get-still-objects
      (c-lambda (scheme-object int) int #<<END-C
    int count = 0;
    ___WORD *base = ___CAST(___WORD*,still_objs);
    while (base != 0 && count < ___arg2)
    {
     ___SCMOBJ next = ___TAG((base + ___STILL_HAND_OFS - ___BODY_OFS),
                             (___HD_SUBTYPE(base[___STILL_BODY_OFS-1]) == ___sPAIR?
                              ___tPAIR : ___tSUBTYPED));
     ___VECTORSET(___arg1, ___FIX(count), next);
     count++;
     base = ___CAST(___WORD*,base[___STILL_LINK_OFS]);
    }
    ___return(count);
    END-C
    ))
    
    (define get-still-objects/refcount
      (c-lambda (scheme-object int) int #<<END-C
    int count = 0;
    ___WORD *base = ___CAST(___WORD*,still_objs);
    while (base != 0 && count < ___arg2)
    {
     if (base[___STILL_REFCOUNT_OFS])
      {
       ___SCMOBJ next = ___TAG((base + ___STILL_HAND_OFS - ___BODY_OFS),
                               (___HD_SUBTYPE(base[___STILL_BODY_OFS-1]) == ___sPAIR?
                                ___tPAIR : ___tSUBTYPED));
       ___VECTORSET(___arg1, ___FIX(count), next);
        count++;
      }
     base = ___CAST(___WORD*,base[___STILL_LINK_OFS]);
    }
    ___return(count);
    END-C
    ))
    
    
    

    external by 284km modified Jan 26, 2018  12  0  1  0

    SICP の 2.23 の練習問題のやつ.scm

    SICP の 2.23 の練習問題のやつ.scm: sicp_2_23.scm
    (define (for-each proc items)
      (if (null? items)
        #f
        (begin
          (proc (car items))
          (for-each proc (cdr items)))
      )
    )
    (for-each (lambda (x) (newline) (display x)) (list 57 321 88))
    
    gosh> (for-each (lambda (x) (newline) (display x)) (list 57 321 88))
    57
    321
    88#f
    
    何もしない。のやり方がわからなくて #f にした...。
    
    

    external by Nulldata modified Jan 25, 2018  11  0  1  0

    Threading macros for Scheme

    Threading macros for Scheme: threading.scm
    (define-syntax ->
      (syntax-rules ()
        ((_ val)
         val)
        ((_ val (f args ...) rest ...)
         (-> (f val args ...)
             rest ...))
        ((_ val f rest ...)
         (-> (f val)
             rest ...))))
    
    (define-syntax ->>
      (syntax-rules ()
        ((_ val)
         val)
        ((_ val (f args ...) rest ...)
         (-> (f args ... val)
             rest ...))
        ((_ val f rest ...)
         (-> (f val)
             rest ...))))
    
    (define-syntax as->
      (syntax-rules ()
        ((_ val name)
         val)
        ((_ val name (f args ...) rest ...)
         (let ((name val))
           (as-> (f args ...) name
                 rest ...)))
        ((_ val name f rest ...)
         (as-> val name (f)
               rest ...))))
    
    
    

    external by Github modified Jan 18, 2018  14  0  1  0

    Generate and find valid sets scm

    Generate and find valid sets scm: generate-and-find-valid-sets.scm
    (define member?
      (lambda (a lat)
        (cond
         ((null? lat)
          #f)
         ((equal? a (car lat))
          #t)
         (else
          (member? a (cdr lat))))))
    
    (member? 'a '(a b c d e f))
    (member? 'a '(1 2 3 4 5 6))
    (member? '(a b) '(a (a b) c))
    
    (define set?
      (lambda (s)
        (cond
         ((null? s)
          #t)
         ((member? (car s) (cdr s))
          #f)
         (else (set? (cdr s))))))
    
    (set? '(1 2 3 4 5))
    (set? '(1 2 3 4 1))
    
    (define catom?
      (lambda (x)
        (and (not (pair? x)) (not (null? x)))))
    
    (define (paste-to-each-element e l)
      (cond
       ((null? l)
        (cons e l))
       (else
        (cond
         ((catom? (car l))
          (append (list (car l)) (list (cons (car l) (list e))) (paste-to-each-element e (cdr l))))
          (else (append (list (car l)) (list (append (car l) (list e))) (paste-to-each-element e (cdr l))))))))
    
    (paste-to-each-element 'd '(a b c))
    (paste-to-each-element 'c '(a b (a b)))
    
    (define (build-combinations)
      (let ((c '()))
        (lambda (element)
          (cond
           ((eqv? element 'give)
    	c)
           ((null? c)
    	(set! c (append (list element) '())))
           (else
            (set! c (paste-to-each-element element c)))))))
    
    (define combine (build-combinations))
    (combine '1)
    (combine 'give)
    (combine '2)
    (combine '3)
    (combine '3)
    
    (define (get-valid-sets sets)
      (cond
       ((null? sets)
        sets)
       ((member? (car sets) (cdr sets))
        (get-valid-sets (cdr sets)))
       ((catom? (car sets))
        (append (list (car sets)) (get-valid-sets (cdr sets))))
       ((set? (car sets))
        (append (list (car sets)) (get-valid-sets (cdr sets))))
       (else
        (get-valid-sets (cdr sets)))))
    
    (get-valid-sets (combine 'give))
    (get-valid-sets '(1 (1 3) (1 3) (1 3 3) (1 2) (1 2 3) (1 2 3) (1 2 3 3) 2 (2 3) (2 3) (2 3 3) 3 (3 3) 3))
    
    
    

    external by Jean Cochrane modified Jan 11, 2018  15  0  1  0

    A Scheme implementation of CracklePop!

    A Scheme implementation of CracklePop!: cracklepop.scm
    (define (crackle-pop)
      (define (iter n)
        (let ((divisible-by-3 (= 0 (remainder n 3)))
              (divisible-by-5 (= 0 (remainder n 5))))
          (cond ((> n 100) "Done printing CracklePop :~)")
                (else
                  (cond ((or divisible-by-3 divisible-by-5)
                           (if divisible-by-3 (display "Crackle"))
                           (if divisible-by-5 (display "Pop")))
                        (else (display n)))
                  (newline)
                  (iter (+ n 1))))))
      (iter 1))
    
    (crackle-pop)
    
    
    • Public Snippets
    • Channels Snippets