working on it ...

Filters

snippets
574
followers
4
Published by snip2code

Scheme

This channel collects useful snippets for Scheme language
Sort by

Found 574 snippets

    public by snip2code modified Aug 13, 2017  41  0  2  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  1757  0  5  0

    Loop 4 times with condition

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

    external by VasMark modified Sep 8, 2017  5  0  1  0

    Как сделать срезанные углы в CSS

    Как сделать срезанные углы в CSS: styles.ss
    div, body { margin: 0; padding: 0 }
    
    div {
        height: 200px;
        background: green;
    }
    
    div:after {
        content: '';
      
        position: absolute;
        left: 0;
        top: 0;
        
        border-top: 30px solid white;
        border-right: 30px solid green;
    }
    
    div:before {
        content: '';
      
        position: absolute;
        right: 0;
        top: 170px;
        
        border-bottom: 30px solid white;
        border-left: 30px solid green;
    }
    
    

    external by MD XF modified Sep 5, 2017  5  0  1  0

    simplestack program

    simplestack program: something.ss
    ZYXWVUTSRQPONMLKJIHGFEDCBA"^(-(@32-);%-^)
    ZYXWVUTSRQPONMLKJIHGFEDCBA                  push ASCII codes for the backwards alphabet
                              "                 turn stack into string
                               ^                push string length
                                (               open do-while loop (do ... while top of stack truthy)
                                 -               decrement string length
                                  (              do while top of stack truthy
                                   @32            print a space
                                      -           decrement string length
                                       )         end do-while loop
                                        ;        pop string length (0)
                                         %       print string
                                          -      knock one character off the front of the string
                                           ^     push string length
                                            )   loop if string length > 0
    
    

    external by Bob Chengbin modified Aug 23, 2017  3  0  1  0

    SICP-Chapter-1

    SICP-Chapter-1: 1.8-v1.ss
    (define (double x) (* 2 x))
    (define (square x) (* x x))
    (define (cube x) (* x x x))
    (define (one-third x) (/ x 3))
    (define (abs x) (if (< x 0) (- 0 x) x))
    
    (define (good-enough? guess x)
     (if (< (abs (- (cube guess) x))  0.00000000001) true false))
    
    (define (improve guess x)
      (one-third (+ (/ x (square guess)) (double guess))))
    
    (define (cbrt-iter guess x)
      (if (good-enough? guess x)
      guess
      (cbrt-iter (improve guess x) x)))
    
    (define (cbrt x) 
      (cbrt-iter 1.0 x))
    
    
    (define (cbrt-iter guess x)
      (if (< (/ (abs (- (improve guess x) guess)) guess) 0.0001)
        guess
        (cbrt-iter (improve guess x) x)))
    
    
    

    external by Louis Warren modified Aug 16, 2017  11  0  1  0

    Proving scheme relationships in minlog

    Proving scheme relationships in minlog: schemes.scm
    (add-pvar-name "P" "Q" (make-arity))
    
    (define mk-disj
      (lambda (a b)
        (mk-imp
          (mk-imp a (pf "Pvar"))
          (mk-imp
            (mk-imp b (pf "Pvar"))
            (pf "Pvar")))))
    
    (define (prove-arbitrary instance scheme . names)
      (begin
        (set-goal (mk-imp (apply scheme names) instance))
        (assume 1)
        (use 1)
        (set-goal (mk-imp instance (apply scheme names)))
        (assume 1)
        (use 1)))
    
    
    ;; Define the scheme, define an arbitrary instance, and check that it really is
    ;; an instance. Of course, we would define the instance using the scheme, but
    ;; this way we check the instance carefully.
    
    (define (lem phi) (mk-disj phi (mk-imp phi (pf "bot"))))
    (define lem-inst (mk-disj (pf "P") (pf "P->bot")))
    (prove-arbitrary lem-inst lem (pf "P"))
    
    (define (wlem phi) (mk-disj
      (mk-imp phi (pf "bot"))
      (mk-imp (mk-imp phi (pf "bot")) (pf "bot"))))
    (define wlem-inst (mk-disj (pf "P->bot") (pf "(P->bot)->bot")))
    (prove-arbitrary wlem-inst wlem (pf "P"))
    
    (define (dgp phi psi) (mk-disj (mk-imp phi psi) (mk-imp psi phi)))
    (define dgp-inst (mk-disj (pf "P -> Q") (pf "Q -> P")))
    (prove-arbitrary dgp-inst dgp (pf "P") (pf "Q"))
    
    
    ;; Prove that lem => wlem by showing that LEM(P) |- WLEM(P)
    (set-goal (mk-imp (lem (pf "P->bot")) wlem-inst))
    (assume 1)
    (use 1)
    
    ;; Prove that dgp => wlem
    (set-goal (mk-imp (dgp (pf "P -> (P->bot)") (pf "(P->bot) -> P")) wlem-inst))
    (search)
    
    
    

    external by Xinyu (Colin) Yang modified Aug 13, 2017  10  0  1  0

    Emacs Sr Speedbar

    Emacs Sr Speedbar: gistfile1.sls
    (require 'sr-speedbar)
    
    (setq speedbar-frame-parameters
          '((minibuffer)
    	(width . 40)
    	(border-width . 0)
    	(menu-bar-lines . 0)
    	(tool-bar-lines . 0)
    	(unsplittable . t)
    	(left-fringe . 0)))
    (setq speedbar-hide-button-brackets-flag t)
    (setq speedbar-show-unknown-files t)
    (setq speedbar-smart-directory-expand-flag t)
    (setq speedbar-use-images nil)
    (setq sr-speedbar-auto-refresh nil)
    (setq sr-speedbar-max-width 70)
    (setq sr-speedbar-right-side nil)
    (setq sr-speedbar-width-console 40)
    
    (when window-system
      (defadvice sr-speedbar-open (after sr-speedbar-open-resize-frame activate)
        (set-frame-width (selected-frame)
                         (+ (frame-width) sr-speedbar-width)))
      (ad-enable-advice 'sr-speedbar-open 'after 'sr-speedbar-open-resize-frame)
    
      (defadvice sr-speedbar-close (after sr-speedbar-close-resize-frame activate)
        (sr-speedbar-recalculate-width)
        (set-frame-width (selected-frame)
                         (- (frame-width) sr-speedbar-width)))
      (ad-enable-advice 'sr-speedbar-close 'after 'sr-speedbar-close-resize-frame))
    
    
    

    external by Hamayama modified Jul 31, 2017  5  0  1  0

    Gauche でテキストファイルを加工するサンプルです。

    Gauche でテキストファイルを加工するサンプルです。: indent_conv.scm
    ;; -*- coding: utf-8 -*-
    ;;
    ;; indent_conv.scm
    ;; 2017-7-31 v1.06
    ::
    ;; <内容>
    ;;   Gauche を使用して、テキストファイルの行頭のインデントを変換します。
    ;;
    ;; <使い方>
    ;;   gosh indent_conv.scm infile outfile
    ;;     infile  : 入力ファイル名
    ;;     outfile : 出力ファイル名
    ;;
    ;; <注意点>
    ;;   ・インデント変換のルールは、タブ1個 → 半角スペース2個 に固定です。
    ;;     (オプション等はありません)
    ;;
    ;;   ・対応するファイルの文字コードは UTF-8(BOMなし) です。
    ;;     出力ファイルの改行コードは LF になります。
    ;;
    ;;   ・インデントのみの行は、改行のみの行に変換します。
    ;;
    ;;   ・標準入出力のリダイレクトは使用できません。
    ;;
    ;;   ・入力ファイル内に複数行にまたがるような文字列リテラルがあって、
    ;;     さらに行頭がタブになっていた場合には、
    ;;     インデントと間違えて変換してしまいます。
    ;;
    (use util.match)
    
    (define space-size 2) ; タブ1個の半角スペース数
    
    ;; 改行コードを CRLF にするとき用
    ;(define (print . args) (for-each display args) (display "\r\n"))
    
    (define (convert-data)
      (define space-str (make-string space-size #\space))
      (for-each
       (lambda (line)
         (rxmatch-if (#/^[ \t]*$/ line) (#f)
           (print "")
           (print (regexp-replace-all #/^( *)\t/ line #"\\1~space-str"))))
       (generator->lseq read-line)))
    
    (define (convert-file infile outfile)
      (with-input-from-file infile
        (lambda ()
          (with-output-to-file outfile convert-data))))
    
    (define (usage out code)
      (display "Usage: gosh indent_conv.scm infile outfile\n" out)
      (exit code))
    
    (define (main args)
      (match args
        ((_ infile outfile) (convert-file infile outfile))
        (_ (usage (current-error-port) 1)))
      0)
    
    
    
    

    external by ?????? ???????? modified Jul 2, 2017  4  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  5  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")
    
    
    • Public Snippets
    • Channels Snippets