Latest comments for language 'Scheme' on doukaku.org

leque's comment on 島の数をカウントする

特にひねりもなく。

(use srfi-43)

(define (count-island target board)
  (let ((h (vector-length board))
        (w (vector-length (vector-ref board 0)))
        (v (vector-map (lambda (i x) (vector-copy x)) board))
        (c (gensym)))
    (define (bref b x y) (vector-ref (vector-ref b y) x))
    (define (bset! b x y o) (vector-set! (vector-ref b y) x o))
    (define (fill-paint! x y)
      (let loop ((x x) (y y))
        (cond ((or (negative? x) (>= y h)))
              ((>= x w)
               (loop 0 (+ y 1)))
              ((equal? (bref v x y) target)
               (bset! v x y c)
               (loop (- x 1) y)
               (loop (+ x 1) y)
               (loop x (+ y 1))))))
    (let loop ((x 0) (y 0) (n 0))
      (cond ((>= y h)
             n)
            ((>= x w)
             (loop 0 (+ y 1) n))
            ((equal? (bref v x y) target)
             (fill-paint! x y)
             (loop (+ x 1) y (+ n 1)))
            (else
             (loop (+ x 1) y n))))))

(let ((bs '(#(#(0 1 1 0)
              #(0 0 1 0)
              #(0 1 0 0)
              #(0 1 1 0))
            #(#(0 0 0 0)
              #(1 0 1 0)
              #(0 1 0 0)
              #(0 0 0 0)))))
  (for-each (lambda (b)
              (format #t "白の島は‾Aつ‾%黒の島は‾Aつ‾%"
                      (count-island 0 b)
                      (count-island 1 b)))
            bs))

[ Scheme ] [ download code ] ]

koguro's comment on inline/embeded bytecode assembly

inline/embeded bytecode assembly (Nested Flatten)

dyncompを使って x86 のネイティブコードを生成してみました。さらにマクロを使いコピーするバイト数が定数の場合はループを展開しアセンブリコードを直接生成します。

Duff's deviceそのものを実装した訳ではないのですが、お題の目的が「bytecodeを埋め込めるか」というところにあるようなので、ご容赦ください(アセンブラも無理矢理使っているだけです)。

(use gauche.uvector)
(use dyncomp)

(cinclude "gauche/uvector.h")

(define-macro (bytecopy to from count)
  `(apply ,(if (integer? count)
               `(clambda (to from count)
                   (let* ((dst :: |char*| (SCM_U8VECTOR_ELEMENTS to))
                          (src :: |char*| (SCM_U8VECTOR_ELEMENTS from)))
                     ,@(do ((i 0 (+ i 1))
                            (asmbody '() (append asmbody
                                                 '((asm "movl   -32(%ebp), %eax")
                                                   (asm "movzbl (%eax), %edx")         
                                                   (asm "movl   -28(%ebp), %eax")
                                                   (asm "movb   %dl, (%eax)")
                                                   (asm "leal   -32(%ebp), %eax")
                                                   (asm "incl   (%eax)")
                                                   (asm "leal   -28(%ebp), %eax")
                                                   (asm "incl   (%eax)")))))
                           ((<= count i) asmbody))))
               `(clambda (to from count::<int>)
                         (let* ((dst :: |char*| (SCM_U8VECTOR_ELEMENTS to))
                                (src :: |char*| (SCM_U8VECTOR_ELEMENTS from))
                                (i :: int))
                           (for ((set! i 0) (< i count) (pre++ i))
                                (set! (* dst) (* src))
                                (pre++ dst)
                                (pre++ src)))))
          (list ,to ,from ,count)))

;; 普通のループによるコピー
(let ((from #u8(1 2 3 4 5 6 7 8 9 10))
      (to (make-u8vector 10)))
  (format #t "before: ~s~%" to)
  (bytecopy to from (u8vector-length to))
  (format #t "after:  ~s~%" to))

;; ループを展開してコピー
(let ((from #u8(1 2 3 4 5 6 7 8 9 10))
      (to (make-u8vector 10)))
  (format #t "before: ~s~%" to)
  (bytecopy to from 10)
  (format #t "after:  ~s~%" to))

[ Scheme ] [ download code ] ]

baal's comment on 疑似並行処理

疑似並行処理 (Nested Flatten)

継続 (call/cc) を使ってスレッドもどき。

(define loop
  (lambda (c1 ls)
    (and c1 (pair? ls)
      (begin (display (car ls))
        (loop (call/cc (lambda (c2) (c1 c2))) (cdr ls))))))

(let ((cc (call/cc (lambda (cc)
  (loop cc '(1 2 3 4 5 6 7 8 9 10))))))
  (loop cc '(A B C D E F G H I J))
  (newline))

[ Scheme ] [ download code ] ]

leque's comment on 疑似並行処理

疑似並行処理 (Nested Flatten)

適当に出力が混ざるようにランダムに thread-yield! しています。

(use srfi-27)
(use gauche.threads)

(define (my-for-each proc xs)
  (cond ((pair? xs)
         (when (< (random-real) 0.5) (thread-yield!))
         (proc (car xs))
         (my-for-each proc (cdr xs)))))

(begin
  (for-each thread-join!
            (map (lambda (xs)
                   (thread-start! (make-thread (cut my-for-each display xs))))
                 '((1 2 3 4 5 6 7 8 9 10)
                   (a b c d e f g h i j))))
  (newline))

[ Scheme ] [ download code ] ]

baal's comment on 疑似並行処理

疑似並行処理 (Nested Flatten)

Scheme では、スレッドについては SRFI-18 と SRFI-21 で決められています。

(use srfi-42)
(use gauche.threads)
(define (main args)
  (let ((a (make-thread (lambda ()
          (do-ec (: n 1 11)
            (begin (display n) (thread-yield!))))))
        (b (make-thread (lambda ()
          (do-ec (: c #\a #\j)
            (begin (display c) (thread-yield!)))))))
    (thread-start! a)
    (thread-start! b)
    (thread-join! a)
    (thread-join! b)
    (newline))
  0)

[ Scheme ] [ download code ] ]

leque's comment on '('と')'の対応

'('と')'の対応 (Nested Flatten)

Gauche だと {} も () の代わりに使えますね。

{define {main args}
  {call-with-input-string {car args}
    {lambda {ip}
      {let loop {{n 0} {c {read-char ip}}}
        {cond {{negative? n} 1}
              {{eof-object? c} n}
              {{char=? c #\u0028} {loop {+ n 1} {read-char ip}}}
              {{char=? c #\u0029} {loop {- n 1} {read-char ip}}}
              {else {loop n {read-char ip}}}}}}}}

[ Scheme ] [ download code ] ]

186's comment on '('と')'の対応

'('と')'の対応 (Nested Flatten)

()の変わりに[]にしました.

Doukaku214.scmと保存して

gosh Doukaku214.scm "(())" -> #t gosh Doukaku214.scm "())" -> #f

となります.

[define [main args]
  [let loop [[i 0] [a [string->list [list-ref args 1]]]]
    [cond [[null? a]
           [if [= i 0] [print #t] [print #f]]]
          [[< i 0] #f]
          [[char=? [integer->char 40] [car a]]
           [loop [+ i 1] [cdr a]]]
          [[char=? [integer->char 41] [car a]]
           [loop [- i 1] [cdr a]]]
          [else
           [loop i [cdr a]]]]]]

[ Scheme ] [ download code ] ]

leque's comment on 世界時計

世界時計 (Nested Flatten)

SLIB の time-zone 手続きを使った方がいいかも。

Thu Oct 30 03:34:58+0900 2008 in Current Locale
Wed Oct 29 18:34:58Z 2008 in GMT
Wed Oct 29 10:34:58-0800 2008 in America/Los Angeles

(use srfi-19)

(let1 ct (current-time)
  (for-each
   (lambda (p)
     (display (date->string (apply time-utc->date ct (cdr p))
                            (format "~~c in ~A~%" (car p)))))
   `(("Current Locale")
     ("GMT" 0)
     ("America/Los Angeles" ,(* 60 60 -8)))))

[ Scheme ] [ download code ] ]

leque's comment on 漢数字で九九の表

漢数字で九九の表 (Nested Flatten)

Lisp らしく（？）

(use gauche.collection)

(define-syntax <>
  (syntax-rules ()
    ((_()) (+))
    ((_(x)) (+ (<> x) (*)))))

(define (main args)
  (do ((i (<>(())) (+ i (<>(())))))
      ((> i (<>(((((((((()))))))))))))
    (do ((j (<>(())) (+ j (<>(())))))
        ((> j (<>(((((((((()))))))))))))
      (format #t "¥t‾A"
              (map-to <string> (cut string-ref "〇一二三四五六七八九" <>)
                      (map digit->integer (number->string (* i j))))))
    (newline))
  0)

[ Scheme ] [ download code ] ]

leque's comment on 漢数字で九九の表

漢数字で九九の表 (Nested Flatten)

どうせだから dotimes も自前で実装して vanilla R5RS で。

(define-syntax dotimes
  (syntax-rules ()
    ((_ (?v ?l) body ...)
     (do ((lim ?l)
          (?v (+) (+ ?v (*))))
         ((>= ?v lim))
       body ...))))

(let* ((n-str "○一二三四五六七八九")
       (ten (string-length n-str))
       (nine (- ten (*))))
  (define (kan-suzi n)
    (let loop ((n n)
               (rs '()))
      (if (< n ten)
          (apply string
                 (reverse (map (lambda (i) (string-ref n-str i)) (cons n rs))))
          (let ((q (quotient n ten))
                (r (remainder n ten)))
            (loop r (cons q rs))))))
  (dotimes (i nine)
    (dotimes (j nine)
      (display " ")
      (display (kan-suzi (* (+ i (*)) (+ j (*))))))
    (newline)))

[ Scheme ] [ download code ] ]

baal's comment on 漢数字で九九の表

漢数字で九九の表 (Nested Flatten)

SRFI-13 使えないのは厳しい。
digit->integer を使わないように書いてみた。

(define 漢数字 "○一二三四五六七八九")

(define (文字列内位置 文字列 文字)
    (let 繰 ((栗鼠 (string->list 文字列)) (結果 '()))
        (if (and (pair? 栗鼠) (not (char=? 文字 (car 栗鼠))))
            (繰 (cdr 栗鼠) (cons (car 栗鼠) 結果))
            (length 結果))))

(define (九九 甲 乙)
    (define 零 (+))
    (define 基数 (string-length 漢数字))
    (let 繰 ((数 (* (文字列内位置 漢数字 甲) (文字列内位置 漢数字 乙))) (結果 '()))
        (let ((商 (quotient 数 基数)) (余 (remainder 数 基数)))
            (if (= 零 商 余)
                (list->string (map (lambda (数) (string-ref 漢数字 数)) 結果))
                (繰 商 (cons 余 結果))))))

(define (九九一覧)
    (for-each
        (lambda (甲)
            (for-each
                (lambda (乙)
                    (display (string #\space))
                    (display (九九 甲 乙)))
                (cdr (string->list 漢数字)))
            (newline))
        (cdr (string->list 漢数字))))

(九九一覧)

[ Scheme ] [ download code ] ]

vvakame's comment on π

π (Nested Flatten)

arcsinのテイラー展開を写経する的な

import (rnrs hashtables (6)))

(define (memoize f)
  (let ((cache (make-eqv-hashtable)))
    (lambda args
      (let ((pvalue (hashtable-ref cache args #f)))
    (or    pvalue
        (let ((result (apply f args)))
          (hashtable-set! cache args result)
          result))))))

(define fact
   (lambda (n)
     (if (<= n 1)
     1
     (* n (fact (- n 1))))))

(define (pi freq)
  (define (iter n value)
    (let ((value2 (+ value (taylor-step n))))
      (if (= n freq)
      value2
      (iter (+ n 1) value2))))
  (define (taylor-step n)
    (/ (fact (* 2 n))
       (*
    (expt 2 (+ (* 4 n) 1))
    (expt (fact n) 2)
    (+ (* 2 n) 1))))
  (* (iter 0 0) 6))

(define result (pi 30))
(display result)
(newline)
(display (inexact result))

[ Scheme ] [ download code ] ]

leque's comment on π

π (Nested Flatten)

Gauche で (use math.const) (print pi) というのも風情がないので三角関数で。

1 2	(display (* (asin 1) 2)) (newline)

[ Scheme ] [ download code ] ]

leque's comment on タブ区切りデータの処理

タブ区切りデータの処理 (Nested Flatten)

書き捨てっぽく。引き数でファイル名を取って標準出力へ。

(use srfi-1)
(use text.csv)

(define (main args)
  (receive (header body) (call-with-input-file (cadr args)
                           (lambda (port)
                             (car+cdr (port->list (make-csv-reader #\tab)
                                                  port))))
    (for-each
     (cute (make-csv-writer #\tab) (current-output-port) <>)
     (cons (list (first header) (third header) (second header) (fourth header))
           (map (cut map x->string <>)
                (sort
                 (map (lambda (vs)
                        (list (string->number (first vs))
                              (third vs)
                              (second vs)
                              (+ (string->number (fourth vs)) 1)))
                      body)
                 (lambda (v1 v2) (< (first v1) (first v2)))))))))

[ Scheme ] [ download code ] ]

leque's comment on 2^i * 3^j * 5^k なる整数

2^i * 3^j * 5^k なる整数 (Nested Flatten)

出題時に考えていた答。平衡木を使うので、求める数の個数を n としたとき、時間計算量は O(log n)、空間計算量は O(n) のはず。

(define (main args)
  (let ((tm (alist->tree-map '((1 . #t)) = <)))
    (let loop ((n (string->number (cadr args)))
               (rs '()))
      (cond
       ((zero? n)
        (print (reverse rs))
        0)
       (else
        (let ((m (car (tree-map-pop-min! tm))))
          (for-each (cut tree-map-put! tm <> #t)
                    (map (cute * m <>) '(2 3 5)))
          (loop (- n 1) (cons m rs))))))))

[ Scheme ] [ download code ] ]

leque's comment on 起動オプションの解析

起動オプションの解析 (Nested Flatten)

args-fold 版。ロングオプション対応。起動例のすべてのパターンを受け付けます（-s を -d にした場合）。

(use srfi-37)
(use gauche.sequence)

(define (main args)
  (receive (debug output quiet rargv)
      (args-fold (cdr args)
                 (list
                  (option '(#\d "debug") #t #f
                          (lambda (option name arg debug output quiet argv)
                            (values (string->number arg) output quiet argv)))
                  (option '(#\o "output") #f #f
                          (lambda (option name arg debug output quiet argv)
                            (values debug #t quiet argv)))
                  (option '(#\q "quiet") #f #f
                          (lambda (option name arg debug output quiet argv)
                            (values debug output #t argv)))
                  )
                 (lambda (option name arg . _)
                   (error "Unrecognized option: " name))
                 (lambda (op debug output quiet argv)
                   (values debug output quiet (cons op argv)))
                 0 #f #f '())
    (cond
     ((not output)
      (format (current-error-port)
              "output option is not supplied.~%"))
     ((not (memv debug '(0 1 2)))
      (format (current-error-port)
              "debug option's value must be 0, 1, or 2: ~A~%" debug))
     ((null? rargv)
      (format (current-error-port)
              "no arguments are supplied.~%"))
     (else
      (format #t "[options]~%o(output): ON~%q(quiet): ~A~%d(debug): ~A~%~%"
              (if quiet 'ON 'OFF)
              debug)
      (format #t "[parameters]~%# of pamameters: ~A~%" (length rargv))
      (for-each-with-index (lambda (i x) (format #t "~A: ~A~%" (+ i 1) x))
                           (reverse rargv))
      (exit 0)))
    1))

[ Scheme ] [ download code ] ]

leque's comment on 起動オプションの解析

起動オプションの解析 (Nested Flatten)

SRFI-37 や SLIB を使う方法もありますが、とりあえずは gauche.parseopt 版。 -oq のような指定や -d1, -d2 のような指定には対応していないようです。

ところで起動例にある -s オプションは -d ですよね？

;; エラー処理で悩んでしまった。

(use gauche.parseopt)
(use gauche.sequence)

(define (main args)
  (let-args (cdr args)
      ((output "o|output" #f)
       (quiet  "q|quiet"  #f)
       (debug  "d|debug=i" 0)
       . argv)
    (cond
     ((not output)
      (format (current-error-port)
              "output option is not supplied.~%"))
     ((not (memv debug '(0 1 2)))
      (format (current-error-port)
              "debug option's value must be 0, 1, or 2: ~A~%" debug))
     ((null? argv)
      (format (current-error-port)
              "no arguments are supplied.~%"))
     (else
      (format #t "[options]~%o(output): ON~%q(quote): ~A~%d(debug): ~A~%~%"
              (if quiet 'ON 'OFF)
              debug)
      (format #t "[parameters]~%# of pamameters: ~A~%" (length argv))
      (for-each-with-index (lambda (i x) (format #t "~A: ~A~%" (+ i 1) x))
                           argv)
      (exit 0)))
    1))

[ Scheme ] [ download code ] ]

leque's comment on LL Golf Hole 9 - トラックバックを打つ

LL Golf Hole 9 - トラックバックを打つ (Nested Flatten)

寄せるだけ。

(use rfc.http)
(use rfc.uri)

(define (alist->query alis)
  (string-join
   (map (lambda (p)
      (format "~A=~A"
          (uri-encode-string (symbol->string (car p)))
          (uri-encode-string (cdr p))))
    alis)
   ";"))

(receive (status _ res)
    (http-post "ll.jus.or.jp"
               "/2008/blog/archives/38/trackback"
               (alist->query
                '((title . "LL Golf Hole 9")
                  (blog_name . "LL Golf Hole 9")
                  (url . "http://ja.doukaku.org/207/")
                  (excerpt . "trackback from LL Golf Hole 9 with Scheme."))))
  (when (string=? status "200")
    (print res))
  0)

[ Scheme ] [ download code ] ]