working on it ...

snippets
599
followers
6

# Scheme

This channel collects useful snippets for Scheme language
Sort by

Found 599 snippets

### 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! */```

### Loop 4 times with condition

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

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

```

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

```

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

```

### 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_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++;
}
___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++;
}
}
___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++;
}
___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++;
}
}
___return(count);
END-C
))

```

### 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 にした...。

```

### Threading macros for Scheme

```(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 ...))))

```

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

```

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