working on it ...

Filters

snippets
563
followers
4
Published by snip2code

Scheme

This channel collects useful snippets for Scheme language
Sort by

Found 563 snippets

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

    Loop 4 times with condition

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

    external by y1j2x34 modified 5 hours ago  1  0  1  0

    scheme reduce

    scheme reduce: reduce.scm
    (define reduce (lambda (fn first arr)
        (define reduce-impl (lambda (left vlist)
            (if 
                (null? vlist)
                left
                (reduce-impl
                  (apply fn (list left (car vlist)))
                  (cdr vlist)
                )
            )
          )
        )
        (reduce-impl first arr)
      )
    )
    
    (reduce + 0 '(1 2 3 4 5)) ;=> 15
    
    

    external by Hamayama modified Thursday at 12:47:41 PM  1  0  1  0

    Schemeによる純粋関数型プログラミングのサンプル

    Schemeによる純粋関数型プログラミングのサンプル: pure.scm
    ;; -*- coding: utf-8 -*-
    ;;
    ;; pure.scm
    ;; 2017-5-25 v1.00
    ;;
    ;; <内容>
    ;;   Schemeによる純粋関数型プログラミングのサンプルです。
    ;;   実行するまで副作用を生じない「アクション」によって、プログラムを組み立てます。
    ;;   (R7RS対応)
    ;;
    ;; <参考>
    ;;   ・「純粋関数型JavaScriptのつくりかた」
    ;;     http://qiita.com/hiruberuto/items/810ecdff0c1674d1a74e
    ;;   ・「純粋関数型Common Lispをつくった話」
    ;;     https://hennin.info/2017/02/10/created-purely-functional-cl/
    ;;
    
    
    ;; ***** Gauche よりコピー *****
    
    (define-library (gauche-mini)
      (export print $)
      (import (scheme base)
              (scheme write))
    
      (begin
        ;; print の定義 (src/libio.scm より)
        ;(define-in-module gauche (print . args) (for-each display args) (newline))
        (define (print . args) (for-each display args) (newline))
    
        ;; $ の定義 (lib/gauche/common-macros.scm より)
        (define-syntax $
          (syntax-rules ()
            (($ x . xs) (%$-split (x . xs) () ()))
            (($) (syntax-error "invalid $ form" ($)))))
        (define-syntax %$-split
          (syntax-rules ($ $*)
            ;; terminal condition
            ((_ ()   segs (e ...)) (%$-gen #f    ((e ...)           . segs)))
            ((_ ($)  segs (e ...)) (%$-gen (arg) ((e ... arg)       . segs)))
            ((_ ($*) segs (e ...)) (%$-gen arg   ((apply e ... arg) . segs)))
            ;; recurse
            ((_ ($ t ...)  segs (e ...)) (%$-split (t ...) ($  (e ...) . segs) ()))
            ((_ ($* t ...) segs (e ...)) (%$-split (t ...) ($* (e ...) . segs) ()))
            ((_ (t0 t ...) segs (e ...)) (%$-split (t ...) segs (e ... t0)))
            ))
        (define-syntax %$-gen
          (syntax-rules ($ $*)
            ;; terminal condition
            ((_ #f     (seg))  seg)
            ((_ formal (seg))  (lambda formal seg))
            ;; recurse
            ((_ type (seg0 $ (s ...) . segs))  (%$-gen type ((s ... seg0) . segs)))
            ((_ type (seg0 $* (s ...) . segs)) (%$-gen type ((apply s ... seg0) . segs)))
            ))
        ))
    
    
    ;; ***** 純粋関数型プログラム用ライブラリ *****
    
    (define-library (pure-func)
      (export pure bind exec wrap)
      (import (scheme base))
    
      (begin
        ;; pure は、値 a をとって「実行すると値 a を返すアクション」を返す
        (define pure (lambda (a) (lambda () a)))
    
        ;; bind は、アクション m と 関数 f を結合したアクションを作る。
        ;; 使い方は、((bind m) f) となる。
        ;; ここで、関数 f を (lambda (x) (n x)) のようにすると、
        ;; アクション m の実行結果 x を次のアクション n に渡すことができる。
        ;; (↓改造して、アクション m が多値を返すケースにも対応してみた)
        ;(define bind (lambda (m) (lambda (f) (lambda () ((f (m)))))))
        (define bind (lambda (m) (lambda (f) (lambda () ((call-with-values m f))))))
    
        ;; exec は、アクション m を実行する
        (define exec (lambda (m) (m)))
    
        ;; wrap は、関数 f をアクションに変換する
        ;; (↓改造して、f が複数の引数を取るケースにも対応してみた)
        ;(define wrap (lambda (f) (lambda (a) (lambda () (f a)))))
        (define wrap (lambda (f) (lambda a (lambda () (apply f a)))))
        ))
    
    
    ;; ***** プログラムのサンプル *****
    
    (import (scheme base)
            ;(only (gauche base) print $)
            (gauche-mini)
            (pure-func)
            (srfi 13)) ; for string-upcase
    
    ;; アクションの定義
    (define action-print         (wrap (lambda a (apply print a) (apply values a))))
    (define action-read-line     (wrap read-line))
    (define action-string-upcase (wrap string-upcase))
    (define action-string-append (wrap string-append))
    (define action-values        (wrap values))
    
    ;; プログラム1
    ;(define program1
    ;  ((bind (pure "abc"))                         (lambda (x)
    ;  ((bind (action-print x))                     (lambda (x)
    ;  ((bind (action-string-append "zzz" x "zzz")) (lambda (x)
    ;  ((bind (action-print x))                     (lambda (x)
    ;  ((bind (action-string-upcase x))             (lambda (x)
    ;  (action-print x))
    ;  )) )) )) )) ))
    
    ;; プログラム1B (Gaucheの $ を使って閉じ括弧を減らしたバージョン)
    (define program1B
      ($
       (bind (pure "abc"))                         $ lambda (x) $
       (bind (action-print x))                     $ lambda (x) $
       (bind (action-string-append "zzz" x "zzz")) $ lambda (x) $
       (bind (action-print x))                     $ lambda (x) $
       (bind (action-string-upcase x))             $ lambda (x)
       (action-print x)
       ))
    
    ;; プログラム2 (多値のテスト)
    (define program2
      ($
       (bind (action-values "a" "b" "c")) $ lambda (x1 x2 x3) $
       (bind (action-print x1 x2 x3))     $ lambda (x1 x2 x3)
       (action-print x1 "-" x2 "-" x3)
       ))
    
    
    ;; ***** プログラムの実行 *****
    
    (print "<program1>")
    ;(exec program1)
    (exec program1B)
    (print)
    (print "<program2>")
    (exec program2)
    
    
    
    
    

    external by Hamayama modified Thursday at 12:47:41 PM  1  0  1  0

    Schemeでの純粋関数型プログラミングのサンプル

    Schemeでの純粋関数型プログラミングのサンプル: pure.scm
    ;; -*- coding: utf-8 -*-
    ;;
    ;; pure.scm
    ;; 2017-5-25 v1.00
    ;;
    ;; <内容>
    ;;   Schemeによる純粋関数型プログラミングのサンプルです。
    ;;   実行するまで副作用を生じない「アクション」によって、プログラムを組み立てます。
    ;;   (R7RS対応)
    ;;
    ;; <参考>
    ;;   ・「純粋関数型JavaScriptのつくりかた」
    ;;     http://qiita.com/hiruberuto/items/810ecdff0c1674d1a74e
    ;;   ・「純粋関数型Common Lispをつくった話」
    ;;     https://hennin.info/2017/02/10/created-purely-functional-cl/
    ;;
    
    
    ;; ***** Gauche よりコピー *****
    
    (define-library (gauche-mini)
      (export print $)
      (import (scheme base)
              (scheme write))
    
      (begin
        ;; print の定義 (src/libio.scm より)
        ;(define-in-module gauche (print . args) (for-each display args) (newline))
        (define (print . args) (for-each display args) (newline))
    
        ;; $ の定義 (lib/gauche/common-macros.scm より)
        (define-syntax $
          (syntax-rules ()
            (($ x . xs) (%$-split (x . xs) () ()))
            (($) (syntax-error "invalid $ form" ($)))))
        (define-syntax %$-split
          (syntax-rules ($ $*)
            ;; terminal condition
            ((_ ()   segs (e ...)) (%$-gen #f    ((e ...)           . segs)))
            ((_ ($)  segs (e ...)) (%$-gen (arg) ((e ... arg)       . segs)))
            ((_ ($*) segs (e ...)) (%$-gen arg   ((apply e ... arg) . segs)))
            ;; recurse
            ((_ ($ t ...)  segs (e ...)) (%$-split (t ...) ($  (e ...) . segs) ()))
            ((_ ($* t ...) segs (e ...)) (%$-split (t ...) ($* (e ...) . segs) ()))
            ((_ (t0 t ...) segs (e ...)) (%$-split (t ...) segs (e ... t0)))
            ))
        (define-syntax %$-gen
          (syntax-rules ($ $*)
            ;; terminal condition
            ((_ #f     (seg))  seg)
            ((_ formal (seg))  (lambda formal seg))
            ;; recurse
            ((_ type (seg0 $ (s ...) . segs))  (%$-gen type ((s ... seg0) . segs)))
            ((_ type (seg0 $* (s ...) . segs)) (%$-gen type ((apply s ... seg0) . segs)))
            ))
        ))
    
    
    ;; ***** 純粋関数型プログラム用ライブラリ *****
    
    (define-library (pure-func)
      (export pure bind exec wrap)
      (import (scheme base))
    
      (begin
        ;; pure は、値 a をとって「実行すると値 a を返すアクション」を返す
        (define pure (lambda (a) (lambda () a)))
    
        ;; bind は、アクション m と 関数 f を結合したアクションを作る。
        ;; 使い方は、((bind m) f) となる。
        ;; ここで、関数 f を (lambda (x) (n x)) のようにすると、
        ;; アクション m の実行結果 x を次のアクション n に渡すことができる。
        ;; (↓改造して、アクション m が多値を返すケースにも対応してみた)
        ;(define bind (lambda (m) (lambda (f) (lambda () ((f (m)))))))
        (define bind (lambda (m) (lambda (f) (lambda () ((call-with-values m f))))))
    
        ;; exec は、アクション m を実行する
        (define exec (lambda (m) (m)))
    
        ;; wrap は、関数 f をアクションに変換する
        ;; (↓改造して、f が複数の引数を取るケースにも対応してみた)
        ;(define wrap (lambda (f) (lambda (a) (lambda () (f a)))))
        (define wrap (lambda (f) (lambda a (lambda () (apply f a)))))
        ))
    
    
    ;; ***** プログラムのサンプル *****
    
    (import (scheme base)
            ;(only (gauche base) print $)
            (gauche-mini)
            (pure-func)
            (srfi 13)) ; for string-upcase
    
    ;; アクションの定義
    (define action-print         (wrap (lambda a (apply print a) (apply values a))))
    (define action-read-line     (wrap read-line))
    (define action-string-upcase (wrap string-upcase))
    (define action-string-append (wrap string-append))
    (define action-values        (wrap values))
    
    ;; プログラム1
    ;(define program1
    ;  ((bind (pure "abc"))                         (lambda (x)
    ;  ((bind (action-print x))                     (lambda (x)
    ;  ((bind (action-string-append "zzz" x "zzz")) (lambda (x)
    ;  ((bind (action-print x))                     (lambda (x)
    ;  ((bind (action-string-upcase x))             (lambda (x)
    ;  (action-print x))
    ;  )) )) )) )) ))
    
    ;; プログラム1B (Gaucheの $ を使って閉じ括弧を減らしたバージョン)
    (define program1B
      ($
       (bind (pure "abc"))                         $ lambda (x) $
       (bind (action-print x))                     $ lambda (x) $
       (bind (action-string-append "zzz" x "zzz")) $ lambda (x) $
       (bind (action-print x))                     $ lambda (x) $
       (bind (action-string-upcase x))             $ lambda (x)
       (action-print x)
       ))
    
    ;; プログラム2 (多値のテスト)
    (define program2
      ($
       (bind (action-values "a" "b" "c")) $ lambda (x1 x2 x3) $
       (bind (action-print x1 x2 x3))     $ lambda (x1 x2 x3)
       (action-print x1 "-" x2 "-" x3)
       ))
    
    
    ;; ***** プログラムの実行 *****
    
    (print "<program1>")
    ;(exec program1)
    (exec program1B)
    (print)
    (print "<program2>")
    (exec program2)
    
    
    
    
    

    external by Thomas modified May 2, 2017  2  0  1  0

    Pascal's Triangle Solution in Scheme Lisp

    Pascal's Triangle Solution in Scheme Lisp: pascalsTriangle.scm
    ; Numering rows and indices starting at 1
    (define (cell-value row index)
      (if (or (= row 1)
              (= index 1)
              (= index row))
          1
          (+ (cell-value (- row 1) (- index 1))
             (cell-value (- row 1) index))))
    
    

    external by chingchai modified May 1, 2017  6  1  1  0

    SLD Geoserver - Point show all labels

    SLD Geoserver - Point show all labels: show_all_label.sld
    <?xml version="1.0" encoding="ISO-8859-1"?>
    <StyledLayerDescriptor version="1.0.0" xsi:schemaLocation="http://www.opengis.net/sld StyledLayerDescriptor.xsd" xmlns="http://www.opengis.net/sld" xmlns:ogc="http://www.opengis.net/ogc" xmlns:xlink="http://www.w3.org/1999/xlink" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance">
        <NamedLayer>
            <Name>Point show all labels</Name>
            <UserStyle>
                <Title>Chingchai: Point show all labels</Title>
                <FeatureTypeStyle>
                    <Rule>
                        <PointSymbolizer>
                            <Graphic>
                                <Mark>
                                    <WellKnownName>circle</WellKnownName>
                                    <Fill>
                                        <CssParameter name="fill">#FF0000</CssParameter>
                                    </Fill>
                                </Mark>
                                <Size>6</Size>
                            </Graphic>
                        </PointSymbolizer>
                        <TextSymbolizer>
                            <Label>
                                <ogc:PropertyName>vill_nam_t</ogc:PropertyName>
                            </Label>
                            <Font>
                                <CssParameter name="font-family">tahoma</CssParameter>
                                <CssParameter name="font-size">8</CssParameter>
                                <CssParameter name="font-style">normal</CssParameter>
                                <CssParameter name="font-weight">bold</CssParameter>
                            </Font>
                            <LabelPlacement>
                                <PointPlacement></PointPlacement>
                            </LabelPlacement>
                            <VendorOption name="maxDisplacement">10</VendorOption>
                            <VendorOption name="labelAllGroup">true</VendorOption>
                            <VendorOption name="goodnessOfFit">0.3</VendorOption>
                            <VendorOption name="spaceAround">0</VendorOption>
                        </TextSymbolizer>
                    </Rule>
                </FeatureTypeStyle>
            </UserStyle>
        </NamedLayer>
    </StyledLayerDescriptor>
    
    

    external by keutoi modified Apr 29, 2017  3  0  1  0

    sicp workspace

    sicp workspace: sicp.scm
    (define (square x) (* x x))
    (define (sum-of-squares x y)
      (+ (square x) (square y)))
    (define (distance-from-origin x y)
      (sqrt (sum-of-squares x y)))
    
    (define (abs x)
      (cond ((< x 0) (- x))
    	(else x)))
    
    (define (sum-of-sq-of-two-larger-numbers a b c)
      (if (< a b)
          (if (< a c)
    	  (sum-of-squares b c)
    	  (sum-of-squares a b))
          (if (< b c)
    	  (sum-of-squares a c)
    	  (sum-of-squares a b))))
    
    (define (a-plus-abs-b a b)
      ((if (> b 0) + -) a b))
    
    ;; recursive definition of factorial
    ;; a simple example of linear recursive process.
    (define (factorial n)
      (if (zero? n)
          1
          (* n (factorial (- n 1)))))
    
    ;; linear iterative process . tail recusive procedure.
    (define (factorial-iter n)
      (define (fact-iter accum count num)
        (if (= count num)
    	accum
    	(fact-iter (* accum (+ count 1))
    		   (+ count 1)
    		   num)))
      (fact-iter 1 1 n))
    
    (define (make-serial-number-generator)
      (let ((current-number 0))
        (lambda ()
          (set! current-number (+ current-number 1))
          current-number)))
    
    (define (sqrt-iter guess x)
      (if (good-enough? guess x)
          guess
          (sqrt-iter (improve guess x)
    		 x)))
    
    (define (improve guess x)
      (average guess (/ x guess)))
    
    (define (average x y)
      (/ (+ x y) 2))
    
    (define (good-enough? guess x)
      (< (abs (- (square guess) x)) 0.001))
    
    (define (sqrt x)
      (sqrt-iter 1.0 x))
    
    ;; exercise 1.10 ackerman function.
    
    (define (A x y)
      (cond ((= y 0) 0)
    	((= x 0) (* 2 y))
    	((= y 1) 2)
    	(else (A (- x 1)
    		 (A x (- y 1))))))
    (define (f n) (A 0 n));; computes 2n
    (define (g n) (A 1 n));; computes 2^n
    (define (h n) (A 2 n))
    ;; gives exponential recursion func i.e., (h n)= 2^(h (- n 1))
    ;; mathematically concise definition would be 2^2^2...^2 n-1 2's
    
    ;;; Tree recursion.
    (define (fibonacci n)
      (cond ((= n 0) 1)
    	((= n 1) 1)
    	(else (+ (fibonacci (- n 1))
    		 (fibonacci (- n 2))))))
    
    ;; iterative process with 3 state variables.
    (define (fibonacci-iter n)
      (define (fib-iter a b count)
        (if (= count 0)
    	b
    	(fib-iter (+ a b) a (- count 1))))
      (fib-iter 1 0 n))
    
    ;;; Counting change.
    ;; write a procedure to compute the number of ways to change
    ;; any given amount of money.
    
    (define (count-change amount denominations)
      (cond ((null? denominations) 0)
    	((zero? amount) 1)
    	((< amount 0) 0)
    	(else (+ (count-change amount (cdr denominations)); without the first denomination.
    		 (count-change (- amount (car denominations)) denominations) ; with one first denomination.
    		 ))))
    
    ;; TODO: write the above function as an iterative process.
    
    
    ;;; exercise 1.11 f(n) = f(n-1) + 2*f(n-2) + 3*f(n-3)
    ;; write a procedure to compute f(n) by an iterative process
    ;; tree recusive procedure
    (define (f-1-11 n)
      (cond ((= n 1) 1)
    	((= n 2) 2)
    	((= n 3) 3)
    	(else (+ (f-1-11 (- n 1))
    		 (* 2 (f-1-11 (- n 2)))
    		 (* 3 (f-1-11 (- n 3)))))))
    ;; iterative procedure
    (define (f-1-11-iter n)
      (define (f-iter a b c d count)
        (if (zero? count)
    	a
    	(f-iter (+ a (* 2 b) (* 3 c)) a b c (- count 1))))
      (cond ((= n 1) 1)
    	((= n 2) 2)
    	((= n 3) 3)
    	(else (f-iter 10 3 2 1 (- n 4)))))
    
    ;;; exercise 1.12 pascal's triangle
    ;; write a procedure that computes the elements of pascal's triangle by
    ;; means of a recursive process.
    (define (pascals-triangle n)
      (define (row n)
        (if (= n 1)
    	(quote (1))
    	(let ((prev (row (- n 1))))
    	  (zip-dis prev (cons 0 prev) '()))))
      (define (zip-dis l r accum)
        (cond ((null? l) (catenate r accum))
    	  ((null? r) (catenate l accum))
    	  (else (zip-dis (cdr l)
    			 (cdr r)
    			 (cons (+ (car l) (car r)) accum)))))
      (define (catenate l r)
        (if (null? l)
    	r
    	(catenate (cdr l) (cons (car l) r))))
      (row n))
    
    ;;; 1.3 Orders of growth.
    
    
    
    
    

    external by Michael Campagnaro modified Apr 24, 2017  7  0  1  0

    macro system

    macro system: gistfile1.scm
    ;; outlet code for implementing traditional macro expansion
    
    ;; macros
    
    (define (expand form)
      (cond
       ((variable? form) form)
       ((literal? form) form)
       ((macro? (car form))
        (expand ((macro-function (car form)) form)))
       ((eq? (car form) 'quote)
        form)
       ((eq? (car form) 'lambda)
        `(lambda ,(car (cdr form))
           ,@(map expand (cdr (cdr form)))))   
       (else (map expand form))))
    
    (define _macros_ {})
    
    (define (macro-function name)
      (ref _macros_ (symbol->string name)))
    
    (define (install-macro name func)
      (put! _macros_ (symbol->string name) func))
    
    (define (macro? name)
      (not (eq? (ref _macros_ (symbol->string name))
                undefined)))
    
    ;; compiler
    
    (define (read src)
      (vector-to-list
       (reader grammar src '[begin])))
    
    (install-macro 'define (lambda (form)
                             `(define* ,(car (cdr form))
                                ,@(cdr (cdr form)))))
    
    (let ((src (fs.readFileSync "example.ol" "utf-8")))
      (pretty (expand (read src))))
    
    ;; (define (foo x y z)
    ;;   (+ x y z))
    ;;
    ;; expand to:
    ;;
    ;; (define* (foo x y z)
    ;;   (+ x y z))
    
    
    

    external by Joeb3219 modified Apr 22, 2017  6  0  1  0

    For Rutgers Pring Prog S2017

    For Rutgers Pring Prog S2017: dictionary-check.ss
    (define allValid?
      (lambda (check dict)
        (reduce
         (lambda (a b)
           (if (equal? a b)
               a
               #f
           )
         )
         (map check dict)
         #t
        )
      )
    )
    
    

    external by vbuaraujo modified Apr 15, 2017  6  0  1  0

    Extended 'if' syntax, allowing 'else' and 'elif' clauses

    Extended 'if' syntax, allowing 'else' and 'elif' clauses: extended-if.scm
    (define-module (elmord extended-if)
      #:export (if*))
    
    (define-syntax if*
      (syntax-rules (else elif)
        ;; Subsume the standard 'if'.
        [(if* condition form1) (if condition form1)]
        [(if* condition form1 form2) (if condition form1 form2)]
        ;; If more forms present, use extra syntax.
        [(if* condition forms ...)
         (if/sub condition () forms ...)]))
    
    (define-syntax if/sub
      (syntax-rules (else elif)
        [(if/sub condition (then-forms ...) else else-forms ...)
         (if condition (begin then-forms ...) (begin else-forms ...))]
        [(if/sub condition1 (then-forms ...) elif condition2 rest ...)
         (if condition1
             (begin then-forms ...)
           (if/sub condition2 () rest ...))]
        [(if/sub condition (then-forms ...) then-form rest ...)
         (if/sub condition (then-forms ... then-form) rest ...)]))
    
    ;;; Example.
    
    (define (signum x)
      (if* (> x 0)
          (display "positive\n")
          +1
       elif (< x 0)
          (display "negative\n")
          -1
       else
          (display "zero\n")
          0))
    
    (signum 42)
    (signum 0)
    (signum -42)
    
    
    
    • Public Snippets
    • Channels Snippets