working on it ...

Filters

snippets
567
followers
4
Published by snip2code

Scheme

This channel collects useful snippets for Scheme language
Sort by

Found 567 snippets

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

    Loop 4 times with condition

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

    external by ?????? ???????? modified Jul 2, 2017  3  0  1  0

    Ересь о синтаксисе let и lambda

    Ересь о синтаксисе let и lambda: let-lambda.scm
    ; Задача: посмотреть с разных сторон на связку синтаксис lambda и let в
    ; контексте вычислительной модели R3. Модель проста: в каждый момент времени
    ; состоянием вычисления является список отложенных вызовов функций, ожидающих
    ; готовности своих параметров. Когда все параметры готовы, функция срабатывает,
    ; порождая продолжение списка отложенных вызовов и операторов записи параметров
    ; в некоторые из этих отложенных вызовов. Отложенные вызовы задаются
    ; конструкцией (run ...), места подстановки параметров -- конструкцией
    ; (pin ...), операторы записи значений в места подстановки -- конструкцией
    ; (bind ...). Меняющиеся во времени множества отложенных вызовов и операций
    ; записи создают некоторый динамический граф потока данных.
    ;
    ; Хочется найти такой вариант синтаксиса, при котором потребовалось бы
    ; минимальное количество связывающих (let, bind, define и прочих) конструкций
    ; для комфортного программирования. Ну и скобок чтобы тоже было поменьше
    ;
    ; Сравнивать варианты lambda и let будем на кошечках: функция вычисления корней
    ; квадратного уравнения (оригинал на Clojure), процедура генерации случайного
    ; значения из распределения Гаусса (оригинал на Arc), процедура распределённого
    ; блочного умножения матриц (оригинал на одном из вариантов языка для R3).
    
    ; Квадратные уравнения
    (defn- solve-square-equation [^double a ^double b ^double c]
      (if (zero? a)
        (if (not= 0.0 b)
          (let [t (/ (- c) b)] (->Roots t t)))
        (let [D (- (* b b) (* 4.0 a c))]
          (if (<= 0.0 D)
            (let [D-sqrt (Math/sqrt D)
                  a-rcpr (/ (* 2.0 a))
                  tp     (* (+ (- b) D-sqrt) a-rcpr)
                  tm     (* (- (- b) D-sqrt) a-rcpr)]
              (->Roots (min tp tm) (max tp tm)))))))
    
    ; Случайная Гаусса
    (def gauss-random (sigma (o mu 0))
      "gausian distributed random with width sigma around mu"
      (withs (u (rand)
              v (* 1.7156 (- (rand) 0.5))
              x (- u 0.449871)
              y (+ abs.v 0.386595)
              q (+ (* x x) (* y (- (* 0.196 y) (* 0.25472 x)))))
        (while (and (> q 0.27597)
                    (or (> q 0.27846) (> (* v v) (* -4 log.u u u))))
          (= u (rand)
             v (* 1.7156 (- (rand) 0.5))
             x (- u 0.449871)
             y (+ abs.v 0.386595)
             q (+ (* x x) (* y (- (* 0.196 y) (* 0.25472 x))))))
        (+ mu (/ (* sigma v) u))))
    
    ; Умножение распределённой матрицы
    (let distributed-matrix-mul
         (lambda R A B
                 (for (lambda i j k (run matrix-block-mul (zip 'i.j) (pin A 'i.k) (pin B 'k.j)))
                      (range l)
                      (range n)
                      (range m))
    
                 (let sum-loop
                      (lambda result r-sum r-blocks n-blocks
                              (if (= 0 n-blocks)
                                  (run bind result (pin sum))
                                  (begin (run matrix-block-add (! pin :sum) (pin r-sum) (zip r-block))
                                         (run sum-loop result (? pin :sum) (r-blocks) (- n-blocks 1))))))
    
                 (for (lambda i j (run sum-loop (pin R 'i.j) (zero-matrix) (? zip 'i.j) m))
                      (range m)
                      (range l))))
    
    ; ПЕРВЫЙ ВАРИАНТ. Синтаксис вида:
    ;   (lambda i1 ... in E1 ... EN)
    ;   (let i1 e1 ... in en)
    ;
    ; Скобок минимум. Конструкция let - с потоковой семантикой. То есть, она в
    ; текущий поток вносит позиции i1, ..., in, которые связываются со значениями,
    ; на которые можно ссылаться дальше. Эту конструкцию в R3 можно сделать
    ; рекурсивной. В R3 не бывает простых переменных, поэтому цикл gauss-random
    ; нужно переписать. В таком синтаксисе всё будет выглядеть так:
    
    (let solve-square-equation
         (lambda a b c
           (if (zero? a)
             (if (not (zero? b))
               (begin (let t (/ (- c) b)) (Roots t t)))
             (begin (let D (- (* b b) (* 4.0 a c)))
                    (if (<= 0.0 D)
                      (begin (let D-sqrt (sqrt D)
                                  a-rcpr (/ (* 2.0 a))
                                  tp     (* (+ (- b) D-sqrt) a-rcpr)
                                  tm     (* (- (- b) D-sqrt) a-rcpr))
                             (Roots (min tp tm) (max tp tm))))))))
    
    ; Здесь, в отличии от оригинала, mu - обязательный параметр
    (let gauss-random
         (lambda sigma mu
           (begin
             (let next (lambda (list (rand) (* 1.7156 (- (rand) 0.5))))
                  loop (lambda u v
                         (begin
                           (let x (- u 0.449871)
                                y (+ (abs v) 0.386595)
                                q (+ (* x x) (* y (- (* 0.196 y) (* 0.25472 x)))))
                           (if (and (> q 0.27597)
                                    (or (> q 0.27846) (> (* v v) (* -4 (log u) u u))))
                             (apply loop (next))
                             (+ mu (/ (* sigma v) u))))))
             (apply loop (next)))))
    
    ; В потоковой версии изменений почти нет. Но если let - потоковая конструкция,
    ; то можно отказаться от bind, внеся в let эту функциональность.
    (let distributed-matrix-mul
         (lambda R A B
                 (for (lambda i j k (run matrix-block-mul (zip 'i.j) (pin A 'i.k) (pin B 'k.j)))
                      (range l)
                      (range n)
                      (range m))
    
                 (let sum-loop
                      (lambda result r-sum r-blocks n-blocks
                              (if (= 0 n-blocks)
                                  (run let result (pin sum))
                                  (begin (run matrix-block-add (! pin :sum) (pin r-sum) (zip r-block))
                                         (run sum-loop result (? pin :sum) (r-blocks) (- n-blocks 1))))))
    
                 (for (lambda i j (run sum-loop (pin R 'i.j) (zero-matrix) (? zip 'i.j) m))
                      (range m)
                      (range l))))
    
    ; Косяки и недостатки этого варианта:
    ;
    ; 1. В процедурах, которые вычисляют значения, а не поток данных необходим
    ; дополнительный синтаксис, чтобы возвращать именно значения. Например, как
    ; begin выше, у которого может быть семантика такая: если в конце блока стоит
    ; вычисление значения, это значение нужно и вернуть. Эту семантику можно описать
    ; в R3. Но сам код вычисления значений, особенно математический, получается
    ; неудобным со множеством begin-ов. В целом конструкция усложняется.
    ;
    ; 2. В таком стиле не описать процедуры, работающие с неопределённым числом
    ; параметров. Точнее, наверное, можно что-нибудь придумать, но вряд ли это будет
    ; красиво. А такие процедуры весьма удобны в математике. Можно посмотреть на
    ; вычисление q в примерах выше.
    ;
    ; 3. Слишком широкий текст получается. Слишком большие отступы до конструкций
    ; тел функций. Для математики это не особо важно. Но удобство написания кода и
    ; его чтения существенно падает.
    ;
    ; Этот вариант хорошо вписывается в модель R3. Но неудобен для описания
    ; вычислительных функций.
    
    ; ВАРИАНТ ДВА. Синтаксис примерно такой:
    ; (lambda i1 ... in E)
    ; (let i1 e1 ... i1 en E)
    ;
    ; С небольшим числом скобок, но let теперь формирует значение, описываемое
    ; последним выражением. Для стилистической согласованности в lambda тоже только
    ; одно выражение в теле. Но так как let теперь не потоковая конструкция, для
    ; формирования значений в потоке (и для объявления того, что выглядит, как
    ; переменная) нужен оператор bind, который, может называться и define, как в
    ; Scheme. Всё выглядит примерно так
    
    (define solve-square-equation
      (lambda a b c
        (if (zero? a)
          (if (not (zero? b))
            (let t (/ (- c) b) (Roots t t)))
          (let D (- (* b b) (* 4.0 a c))
            (if (<= 0.0 D)
              (let D-sqrt (sqrt D)
                   a-rcpr (/ (* 2.0 a))
                   tp     (* (+ (- b) D-sqrt) a-rcpr)
                   tm     (* (- (- b) D-sqrt) a-rcpr)
                (Roots (min tp tm) (max tp tm))))))))
    
    (define gauss-random
      (lambda sigma mu
        (let next (lambda (list (rand) (* 1.7156 (- (rand) 0.5))))
             loop (lambda u v
                    (let x (- u 0.449871)
                         y (+ (abs v) 0.386595)
                         q (+ (* x x) (* y (- (* 0.196 y) (* 0.25472 x))))
                      (if (and (> q 0.27597)
                               (or (> q 0.27846) (> (* v v) (* -4 (log u) u u))))
                        (apply loop (next))
                        (+ mu (/ (* sigma v) u)))))
          (apply loop (next)))))
    
    (define distributed-matrix-mul
      (lambda R A B
        (begin
          (for (lambda i j k (run matrix-block-mul (zip 'i.j) (pin A 'i.k) (pin B 'k.j)))
               (range l)
               (range n)
               (range m)))
          (let sum-loop
               (lambda result r-sum r-blocks n-blocks
                 (if (= 0 n-blocks)
                   (run define result (pin sum))
                   (begin (run matrix-block-add (! pin :sum) (pin r-sum) (zip r-block))
                          (run sum-loop result (? pin :sum) (r-blocks) (- n-blocks 1)))))
            (for (lambda i j (run sum-loop (pin R 'i.j) (zero-matrix) (? zip 'i.j) m))
                 (range m)
                 (range l)))))
    
    ; В принципе, неплохой вариант. И проблемы с неопределённым списком параметров
    ; функции он решает, потому что тело -- это всего последнее выражение в lambda,
    ; поэтому остальное содержимое может быть оформлено, как угодно.
    ;
    ; Но есть проблемы восприятия, написания и редактирования кода. В потоковых
    ; функциях, обычно, стоит множество операторов формирования этого потока. Много
    ; run и define. И для таких функций в большинстве случаев необходимо будет
    ; писать (lambda x1 ... xn (begin ...)), что несколько напрягает чувство
    ; прекрасного. Кроме того, в таком варианте превращение тела функции (ну, или
    ; тела let) из одного оператора в тело из нескольких, будет нетривиальной
    ; задачей. Появятся висящие begin-ы, как это происходит в Си, когда все начинают
    ; писать (или требовать прямо в синтаксисе) if (x) { ... }, даже если в фигурных
    ; скобках один оператор.
    ;
    ; Можно, в принципе, засахарить define в стиле Scheme и использовать конструкцию
    ; (define (name x1 ... xn) ...). Но тогда синтаксис обычной lambda и такого
    ; define будут существенно несогласованы. И перенос кода из одной конструкции в
    ; другую будет осложнён. Но можно поменять lambda и let.
    
    ; ВАРИАНТ ТРИ. Синтаксис вида:
    ; (lambda (x1 ... en) E1 ... Ek) 
    ; (let (x1 e1 ... xn en) E1 ... Ek)
    ;
    ; Скобок больше, зато begin не нужен. Синтаксис (define (fn x1 ... xn) E1 ...
    ; Ek) будет согласован с lambda. Можно использовать. Выглядеть всё будет
    ; примерно так.
    
    (define (solve-square-equation a b c)
        (if (zero? a)
          (if (not (zero? b))
            (let (t (/ (- c) b)) (Roots t t)))
          (let (D (- (* b b) (* 4.0 a c)))
            (if (<= 0.0 D)
              (let (D-sqrt (sqrt D)
                    a-rcpr (/ (* 2.0 a))
                    tp     (* (+ (- b) D-sqrt) a-rcpr)
                    tm     (* (- (- b) D-sqrt) a-rcpr))
                (Roots (min tp tm) (max tp tm)))))))
    
    (define (gauss-random sigma mu)
      (let (next (lambda () (list (rand) (* 1.7156 (- (rand) 0.5))))
            loop (lambda (u v)
                   (let (x (- u 0.449871)
                         y (+ (abs v) 0.386595)
                         q (+ (* x x) (* y (- (* 0.196 y) (* 0.25472 x)))))
                     (if (and (> q 0.27597)
                              (or (> q 0.27846) (> (* v v) (* -4 (log u) u u))))
                       (apply loop (next))
                       (+ mu (/ (* sigma v) u))))))
        (apply loop (next))))
    
    (define (distributed-matrix-mul R A B)
      (for (lambda (i j k) (run matrix-block-mul (zip 'i.j) (pin A 'i.k) (pin B 'k.j)))
           (range l)
           (range n)
           (range m))
      (let (sum-loop
            (lambda (result r-sum r-blocks n-blocks)
              (if (= 0 n-blocks)
                (run define result (pin sum))
                (begin (run matrix-block-add (! pin :sum) (pin r-sum) (zip r-block))
                       (run sum-loop result (? pin :sum) (r-blocks) (- n-blocks 1))))))
        (for (lambda (i j) (run sum-loop (pin R 'i.j) (zero-matrix) (? zip 'i.j) m))
             (range m)
             (range l))))
    
    ; Технически, это хороший вариант. И скобок не так много. Но есть проблема с
    ; восприятием. Возможно, это моя персональная проблема. Плохо воспринимаются
    ; такие вот висяки:
    ;
    ; (let (x ...
    ;       y ...
    ;
    ; (let (next ...
    ;       loop
    ;       (lambda (u v) ...)
    ;
    ; После некоторого опыта чтения и написания кода на Lisp конструкция вида (x
    ; очень отчётливо мозгом воспринимается, как начало некой целой формы, которая
    ; должна редуцироваться в некоторое значение. Поэтому мозг throttle-ится немного
    ; при чтении таких конструкций. Выходом может быть использование [] в стиле
    ; Clojure. Но в таком стиле, всё равно, не хватает какой-то сгруппированности,
    ; что ли, переменной со своим значением. Плюс в таком синтаксисе, выравнивание
    ; выглядит грубо. В столбик, без явного обозначения, что к чему относится:
    
    (let (next
          (lambda () (list (rand) (* 1.7156 (- (rand) 0.5))))
    
          loop
          (lambda (u v)
            (let (x (- u 0.449871)
                  y (+ (abs v) 0.386595)
                  q (+ (* x x) (* y (- (* 0.196 y) (* 0.25472 x)))))
              (if (and (> q 0.27597)
                       (or (> q 0.27846) (> (* v v) (* -4 (log u) u u))))
                (apply loop (next))
                (+ mu (/ (* sigma v) u))))))
      (apply loop (next)))
    
    ; Необходимо вносить вертикальные разрывы в код. Или делать так:
    
    (let (next
            (lambda () (list (rand) (* 1.7156 (- (rand) 0.5))))
          loop
            (lambda (u v)
              (let (x (- u 0.449871)
                    y (+ (abs v) 0.386595)
                    q (+ (* x x) (* y (- (* 0.196 y) (* 0.25472 x)))))
                (if (and (> q 0.27597)
                         (or (> q 0.27846) (> (* v v) (* -4 (log u) u u))))
                  (apply loop (next))
                  (+ mu (/ (* sigma v) u))))))
      (apply loop (next)))
    
    ; Группировка loop со своей lambda воспринимается плохо. Поэтому, скажу «нет»
    ; стилю Пола Грэма (он его в Arc предложил).
    
    ; ВАРИАНТ ЧЕТЫРЕ. Вполне может быть, что это всё было продумано уже 100 раз в
    ; Lisp сообществе. И вполне себе можно остаться с классическим стилем. Скобок в
    ; нём больше, но неким странным образом он читается и воспринимается лучше.
    ; Поэтому, классика:
    
    (define (solve-square-equation a b c)
        (if (zero? a)
          (if (not (zero? b))
            (let ((t (/ (- c) b))) (Roots t t)))
          (let D (- (* b b) (* 4.0 a c))
            (if (<= 0.0 D)
              (let ((D-sqrt (sqrt D))
                    (a-rcpr (/ (* 2.0 a)))
                    (tp (* (+ (- b) D-sqrt) a-rcpr))
                    (tm (* (- (- b) D-sqrt) a-rcpr)))
                (Roots (min tp tm) (max tp tm)))))))
    
    (define (gauss-random sigma mu)
      (let ((next (lambda () (list (rand) (* 1.7156 (- (rand) 0.5)))))
            (loop
              (lambda (u v)
                (let ((x (- u 0.449871))
                      (y (+ (abs v) 0.386595))
                      (q (+ (* x x) (* y (- (* 0.196 y) (* 0.25472 x))))))
                  (if (and (> q 0.27597)
                           (or (> q 0.27846) (> (* v v) (* -4 (log u) u u))))
                    (apply loop (next))
                    (+ mu (/ (* sigma v) u)))))))
        (apply loop (next))))
    
    (define (distributed-matrix-mul R A B)
      (for (lambda (i j k) (run matrix-block-mul (zip 'i.j) (pin A 'i.k) (pin B 'k.j)))
           (range l)
           (range n)
           (range m))
      (let ((sum-loop
              (lambda (result r-sum r-blocks n-blocks)
                (if (= 0 n-blocks)
                  (run define result (pin sum))
                  (begin (run matrix-block-add (! pin :sum) (pin r-sum) (zip r-block))
                         (run sum-loop result (? pin :sum) (r-blocks) (- n-blocks 1)))))))
        (for (lambda (i j) (run sum-loop (pin R 'i.j) (zero-matrix) (? zip 'i.j) m))
             (range m)
             (range l))))
    
    ; А ещё, в качестве шутки, может быть какой-нибудь забавная греко-славянская
    ; типизированная ересь:
    
    (тип (при ((дробное t)) (одно-из (λ (t) t) (λ (t t) t))) случайная-Гаусса)
    (это случайная-Гаусса 
         (λ (σ) (случайная-Гаусса σ 0))
         (λ ((тип t σ) μ)
            (при ((проба (λ () (n-ка (тип t (случайная))
                                     (* 1.7156 (- (тип t (случайная)) 0.5)))))
                  (тест (λ ((n-ка u v))
                           (при ((x (- u 0.449871))
                                 (y (+ (abs v) 0.386595))
                                 (q (+ (* x x)
                                       (* y (- (* 0.196 y) (* 0.25472 x)))))))
                                (если (∧ (> q 0.27597)
                                         (∨ (> q 0.27846)
                                            (> (* v v) (* -4 (log u) u u))))
                                      (тест (проба))
                                      (+ μ (/ (* σ v) u))))))
               (тест (проба))))) 
    
    
    

    external by Yusuke Shimizu modified Jun 27, 2017  3  0  1  0

    gauche thread-pool test

    gauche thread-pool test: gauche-thread-pool-test.scm
    #!/usr/bin/env gosh
    
    (use control.thread-pool)
    
    (define (log msg)
      (print (sys-time) ": " msg))
    
    (log "start")
    
    (define (run ls)
      (let* ((pool (make-thread-pool 5)))
        (begin
          (map (^n (add-job! pool
                             (lambda()
                               (begin
                                 (log (list "at" n))
                                 (sys-sleep 1)
                                 ))))
               ls)
          (wait-all pool))))
    
    (run '(1 2 3 4 5 6 7 8 9))
    
    (log "finish")
    
    

    external by Francisco Gómez García modified Jun 26, 2017  4  0  1  0

    My personal GuixSD configuration

    My personal GuixSD configuration: config.scm
    (use-modules (gnu) (gnu system nss))
    (use-service-modules networking desktop)
    (use-package-modules admin certs ncurses gnome)
    
    (operating-system
      (host-name "gnu")
      (timezone "Europe/Madrid")
      (locale "es_ES.utf8")
    
      (bootloader (grub-configuration (device "/dev/sda")
                                      (terminal-outputs '(console))))
      (file-systems (cons (file-system
                            (device "my-root")
                            (title 'label)
                            (mount-point "/")
                            (type "ext4"))
                          %base-file-systems))
    
      (users (cons (user-account
                    (name "xerz")
                    (comment "Francisco Gómez")
                    (group "users")
                    (supplementary-groups '("wheel"
                                            "audio"
                                            "video"
                                            "cdrom"
                                            "netdev"))
                    (home-directory "/home/xerz"))
               %base-user-accounts))
    
      (packages (cons* nss-certs
                       ncurses
                       gnome
                       %base-packages))
    
      (services (cons*
                  (console-keymap-service "es")
                  (gnome-desktop-service)
                  %desktop-services))
    
      (name-service-switch %mdns-host-lookup-nss))
    
    

    external by tomtitchener modified Jun 2, 2017  2  0  1  0

    The Little Schemer: applicative-order Y from Chapter 9 "... and Again, and Again, and Again, ..."

    The Little Schemer: applicative-order Y from Chapter 9 "... and Again, and Again, and Again, ...": little-schemer-y.ss
    #! /usr/local/bin/scheme --libdirs --script
    
    ;; chmod +x ./y.ss
    ;; echo "" | ./y.ss
    
    ;; The Little Schemer,  Friedman & Felleisen, 4th Edition
    ;;
    ;; Chapter 9 "... and Again, and Again, and Again, ..."
    ;;
    ;; Skipping partial vs. total functions with examples Ackerman, termination.
    ;; Mainly pages 160-173 following derivation of applicative-order Y.
    ;; For "applicative-order imperative Y (Y!), see The Seasoned Schemer,
    ;; chapter 16.
    ;;
    
    ;; page 151
    
    ;; example of bottom in scheme, "the most partial function"
    ;;
    ;; > (eternity 'foo)
    ;;   ^C ^C
    ;; break> quit
    (define eternity
      (lambda (f)
        (eternity f)))
    
    ;; page 160
    
    ;; utility routine used in text
    ;; > (add1 2)
    ;; 3
    (define add1
      (lambda (n)
        (+ 1 n)))
    
    (display "(add1 2)")
    (newline)
    (display (add1 2))
    (newline)
    
    ;; recursive point-of-reference
    
    ;; > (length '(1 2 3))
    ;; 3
    (define length (lambda (l) (cond ((null? l) 0) (else (add1 (length (cdr l)))))))
    
    (display "(length '(1 2 3))")
    (newline)
    (display (length '(1 2 3)))
    (newline)
    
    ;; now move to nameless, have to type these into repl, display statements show application to lists
    
    ;; base case: length function for lists of only length zero only
    ;;
    ;; > ((lambda (l) (cond ((null? l) 0) (else (add1 (eternity (cdr l)))))) '())
    ;; 0
    
    (display "((lambda (l) (cond ((null? l) 0) (else (add1 (eternity (cdr l)))))) '()))")
    (newline)
    (display ((lambda (l) (cond ((null? l) 0) (else (add1 (eternity (cdr l)))))) '()))
    (newline)
    
    ;; page 161
    
    ;; mechanical extension: in-line embedding in "(else (add1 .." of same function, works for lists of length zero and length one only,
    ;; same structure, if list isn't empty, add1 to application of repeat of same function to cdr of list, text shows extension to lists
    ;; of length 0, 1, or 2 by second in-line embedding around second "(else (add1 ..."
    ;;
    ;; > ((lambda (l) (cond ((null? l) 0) (else (add1 ((lambda (l) (cond ((null? l) 0) (else (add1 (eternity (cdr l)))))) (cdr l)))))) '(0))
    ;; 1
    ;; > ((lambda (l) (cond ((null? l) 0) (else (add1 ((lambda (l) (cond ((null? l) 0) (else (add1 (eternity (cdr l)))))) (cdr l)))))) '())
    ;; 0
    
    (display "((lambda (l) (cond ((null? l) 0) (else (add1 ((lambda (l) (cond ((null? l) 0) (else (add1 (eternity (cdr l)))))) (cdr l)))))) '(0))")
    (newline)
    (display ((lambda (l) (cond ((null? l) 0) (else (add1 ((lambda (l) (cond ((null? l) 0) (else (add1 (eternity (cdr l)))))) (cdr l)))))) '(0)))
    (newline)
    
    (display "((lambda (l) (cond ((null? l) 0) (else (add1 ((lambda (l) (cond ((null? l) 0) (else (add1 (eternity (cdr l)))))) (cdr l)))))) '()))")
    (newline)
    (display ((lambda (l) (cond ((null? l) 0) (else (add1 ((lambda (l) (cond ((null? l) 0) (else (add1 (eternity (cdr l)))))) (cdr l)))))) '()))
    (newline)
    
    ;; page 162
    
    ;; first-level abstraction: bind terminal function "eternity" with outer lambda, refer to binding "length" in terminal position, revert to length 
    ;; zero list two levels of binding, first of "eternity" to "length", leaves you with lambda looking for a list, then next of list "'()" to "l" in 
    ;; inner lambda
    ;;
    ;; > (((lambda (length) (lambda (l) (cond ((null? l) 0) (else (add1 (length (cdr l))))))) eternity) '())
    ;; 0
    
    (display "(((lambda (length) (lambda (l) (cond ((null? l) 0) (else (add1 (length (cdr l))))))) eternity) '())")
    (newline)
    (display (((lambda (length) (lambda (l) (cond ((null? l) 0) (else (add1 (length (cdr l))))))) eternity) '()))
    (newline)
    
    ;; page 163
    
    ;; mechanical extension: where "eternity" was bound to "length" before, bind it first to "g", then bind enclosed lambda to "f", leaving outermost
    ;; lambda taking list, testing it for null else does add1 with "f" resolved to lamdba that tests for null else add1 with "g" resolved to eternity,
    ;; works for lists of lenth zero or one only
    ;;
    ;; > (((lambda (f) (lambda (l) (cond ((null? l) 0) (else (add1 (f (cdr l))))))) ((lambda (g) (lambda (l) (cond ((null? l) 0) (else (add1 (g (cdr l))))))) eternity)) '(0))
    ;; 1
    ;; > (((lambda (f) (lambda (l) (cond ((null? l) 0) (else (add1 (f (cdr l))))))) ((lambda (g) (lambda (l) (cond ((null? l) 0) (else (add1 (g (cdr l))))))) eternity)) '())
    ;; 0
    
    (display "(((lambda (f) (lambda (l) (cond ((null? l) 0) (else (add1 (f (cdr l))))))) ((lambda (g) (lambda (l) (cond ((null? l) 0) (else (add1 (g (cdr l))))))) eternity)) '(0))")
    (newline)
    (display (((lambda (f) (lambda (l) (cond ((null? l) 0) (else (add1 (f (cdr l))))))) ((lambda (g) (lambda (l) (cond ((null? l) 0) (else (add1 (g (cdr l))))))) eternity)) '(0)))
    (newline)
    
    (display "(((lambda (f) (lambda (l) (cond ((null? l) 0) (else (add1 (f (cdr l))))))) ((lambda (g) (lambda (l) (cond ((null? l) 0) (else (add1 (g (cdr l))))))) eternity)) '())")
    (newline)
    (display (((lambda (f) (lambda (l) (cond ((null? l) 0) (else (add1 (f (cdr l))))))) ((lambda (g) (lambda (l) (cond ((null? l) 0) (else (add1 (g (cdr l))))))) eternity)) '()))
    (newline)
    
    ;; page 164
    
    ;; second-level abstraction: bind application of function in outermost lambda to its own function "mk-length", applied once to yield
    ;; lambda that takes a list of length zero and answers length 0
    ;;
    ;; > (((lambda (mk-length) (mk-length eternity)) (lambda (length) (lambda (l) (cond ((null? l) 0) (else (add1 (length (cdr l)))))))) '())
    ;; 0
    
    (display "(((lambda (mk-length) (mk-length eternity)) (lambda (length) (lambda (l) (cond ((null? l) 0) (else (add1 (length (cdr l)))))))) '())")
    (newline)
    (display (((lambda (mk-length) (mk-length eternity)) (lambda (length) (lambda (l) (cond ((null? l) 0) (else (add1 (length (cdr l)))))))) '()))
    (newline)
    
    ;; mechanical extension:  now nested application is up-front and more easily self-contained making it possible to type in a length function that works
    ;; for lists of lengths zero, one, or two -- now the tail stays the same and each extension is added to the first lambda only -- to me, this abstraction
    ;; and the consequent extension are giant steps toward the eventual syntax of Y, lets you see where application to a function to itself originates
    ;;
    ;; > (((lambda (mk-length) (mk-length (mk-length eternity))) (lambda (length) (lambda (l) (cond ((null? l) 0) (else (add1 (length (cdr l)))))))) '(1))
    ;; 1
    
    (display "(((lambda (mk-length) (mk-length (mk-length eternity))) (lambda (length) (lambda (l) (cond ((null? l) 0) (else (add1 (length (cdr l)))))))) '(1))")
    (newline)
    (display (((lambda (mk-length) (mk-length (mk-length eternity))) (lambda (length) (lambda (l) (cond ((null? l) 0) (else (add1 (length (cdr l)))))))) '(1)))
    (newline)
    
    ;; > (((lambda (mk-length) (mk-length (mk-length (mk-length eternity)))) (lambda (length) (lambda (l) (cond ((null? l) 0) (else (add1 (length (cdr l)))))))) '(0 1))
    ;; 2
    
    (display "(((lambda (mk-length) (mk-length (mk-length (mk-length eternity)))) (lambda (length) (lambda (l) (cond ((null? l) 0) (else (add1 (length (cdr l)))))))) '(0 1))")
    (newline)
    (display (((lambda (mk-length) (mk-length (mk-length (mk-length eternity)))) (lambda (length) (lambda (l) (cond ((null? l) 0) (else (add1 (length (cdr l)))))))) '(0 1)))
    (newline)
    
    ;; page 165
    
    ;; re-naming to reveal the name of the function that gets applied to itself doesn't matter, which lets us do away with "eternity",
    ;;
    ;; > (((lambda (mk-length) (mk-length mk-length)) (lambda (mk-length) (lambda (l) (cond ((null? l) 0) (else (add1 (mk-length (cdr l)))))))) '())
    ;; 0
    
    ;; apply it one too many times and instead of an endless loop you land with a lambda that gets passed to add1 instead of a number, whops
    ;;
    ;; > (((lambda (mk-length) (mk-length mk-length)) (lambda (mk-length) (lambda (l) (cond ((null? l) 0) (else (add1 (mk-length (cdr l)))))))) '(0))
    ;; Exception in +: #<procedure> is not a number
    ;; Type (debug) to enter the debugger.
    
    (display "(((lambda (mk-length) (mk-length mk-length)) (lambda (mk-length) (lambda (l) (cond ((null? l) 0) (else (add1 (mk-length (cdr l)))))))) '())")
    (newline)
    (display (((lambda (mk-length) (mk-length mk-length)) (lambda (mk-length) (lambda (l) (cond ((null? l) 0) (else (add1 (mk-length (cdr l)))))))) '()))
    (newline)
    
    ;; page 166
    
    ;; mechanical extension:  except it's not really that simple, because now to extend, we nest in the tail, first with a return to "eternity" ...
    ;; 
    (display "(((lambda (mk-length) (mk-length mk-length)) (lambda (mk-length) (lambda (l) (cond ((null? l) 0) (else (add1 ((mk-length eternity) (cdr l)))))))) '(apples)))")
    (newline)
    (display (((lambda (mk-length) (mk-length mk-length)) (lambda (mk-length) (lambda (l) (cond ((null? l) 0) (else (add1 ((mk-length eternity) (cdr l)))))))) '(apples)))
    (newline)
    
    ;; page 167
    
    ;; ... next with the big step:  replace "eternity" with self-application and repeat until the list is empty ... sparkling, aweseome, astounding magic!
    ;; this takes lots and lots of concentration to unwind (https://www.youtube.com/watch?v=lIpev8JXJHQ)
    ;;
    (display "(((lambda (mk-length) (mk-length mk-length)) (lambda (mk-length) (lambda (l) (cond ((null? l) 0) (else (add1 ((mk-length mk-length) (cdr l)))))))) '(apples oranges)))")
    (newline)
    (display (((lambda (mk-length) (mk-length mk-length)) (lambda (mk-length) (lambda (l) (cond ((null? l) 0) (else (add1 ((mk-length mk-length) (cdr l)))))))) '(apples oranges)))
    (newline)
    
    (display "(((lambda (mk-length) (mk-length mk-length)) (lambda (mk-length) (lambda (l) (cond ((null? l) 0) (else (add1 ((mk-length mk-length) (cdr l)))))))) '(apples oranges grapes)))")
    (newline)
    (display (((lambda (mk-length) (mk-length mk-length)) (lambda (mk-length) (lambda (l) (cond ((null? l) 0) (else (add1 ((mk-length mk-length) (cdr l)))))))) '(apples oranges grapes)))
    (newline)
    
    (display "(((lambda (mk-length) (mk-length mk-length)) (lambda (mk-length) (lambda (l) (cond ((null? l) 0) (else (add1 ((mk-length mk-length) (cdr l)))))))) (iota 100)))")
    (newline)
    (display (((lambda (mk-length) (mk-length mk-length)) (lambda (mk-length) (lambda (l) (cond ((null? l) 0) (else (add1 ((mk-length mk-length) (cdr l)))))))) (iota 100)))
    (newline)
    
    ;; but we're not close enough to Y quite yet
    
    ;; 
    
    
    

    external by y1j2x34 modified May 27, 2017  25  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 May 25, 2017  17  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 May 25, 2017  9  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  18  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  61  7  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>
    
    
    • Public Snippets
    • Channels Snippets