shirok

(defun expand-cxr (ads)
  (labels ((expand (ads)
                   (cond
                    ((null ads) 'x)
                    ((equalp (car ads) #\a) `(cl:car ,(expand (cdr ads))))
                    (t `(cl:cdr ,(expand (cdr ads)))))))
    (let* ((nam (coerce `(#\c ,@ads #\r) 'string))
           (sym (intern (ecase (readtable-case *cxr-readtable*)
                         ((:upcase) (string-upcase nam))
                         ((:downcase) (string-downcase nam))

shirok

;; f(z) = z^3 + 2z^2 + 1
(define (f z) (+ (expt z 3) (* 2 (square z)) 1))

;; f'(z) = 3z^2 + 4z
(define (df z) (+ (* 3 (square z)) (* 4 z)))

;; ニュートン法。初期値zから出発。変化が充分少なくなったらその時のzがf(z)=0の解。
;; 微分が0に近くなった場合はエラーとする。
;; 循環してしまうケースは検出しない (止まらなくなる)
(define (newton z)

shirok

(defvar *original-readtable* *readtable*)
(defvar *cxr-readtable* (copy-readtable *original-readtable*))

(defconstant +constituents+
  (remove-if #'get-macro-character
             "!$%&0123456789<=>?[]^_{}~.+-*/@ABCDEFGHIJKLMNOPQRTSUVWXYZabcdefghijklmnopqrstuvwxyz"))

(defun cxr-reader (stream char)
  (let* ((chars (loop with cs = `(,char)
                      for c = (peek-char nil stream nil nil t)

shirok

(define threes '#0=(#f #f #t . #0#))
(define fives  '#1=(#f #f #f #f #t . #1#))
(define digits '#2=(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 . #2#))
(define one (list (cdr digits)))

(define (inc num)
  (if (eqv? (caar num) #\9)
    (if (null? (cdr num))
      (cons digits one)
      (cons digits (inc (cdr num))))

shirok

;; -*- coding:utf-8 -*-

(use gauche.sequence)
(use util.match)
(use util.combinations)
(use srfi-197)                          ;chain

(define (num-fingers hands)
  (define (f hand) (case hand
                     [(グー) 0]

shirok

gosh> (define-method object-+ ((f <procedure>) (g <procedure>)) (lambda (x) (+ (f x) (g x))))
#<generic object-+ (1)>
gosh> (define (f x) (* x 2))
f
gosh> (define (g x) (* x 3))
g
gosh> ((+ f g) 4)
20

shirok

(defn- start-server []
  (-> (duct/resource "my_project/config.edn")
      (duct/read-config)
      (duct/prep-config [:duct.profile/test])
      (ig/init [:duct.router/ataraxy :duct.migrator/ragtime])))

(def #^:dynamic the-system
  "During the test, this var holds the initialized system map."
  nil)

shirok

(use util.match)
(use data.sparse)

(define-macro (make-dumper . labels)
  `(lambda (memory)
     (list ,@(map (^l `(list ',l (~ memory ,l))) labels))))

(define (run program memory dumper)
  (define (DJN pc)
    (match-let1 (dest ptr) (~ program pc)

shirok

(define (filter pred xs)
  (define (skip xs)
    (cond [(null? xs) xs]
          [(pred (car xs)) xs]
          [else (skip (cdr xs))]))
  (unfold null?
          (^[xs] (car xs))
          (^[xs] (skip (cdr xs)))
          (skip xs)))

shirok

(define (filter pred xs)
  (define (skip xs)
    (cond [(null? xs) xs]
          [(pred (car xs)) xs]
          [else (skip (cdr xs))]))
  (unfold (^[xs] (null? (skip xs)))
          (^[xs] (car (skip xs)))
          (^[xs] (cdr (skip xs)))
          xs))