DouKaku? Language detail: Scheme

Scheme(Gauche)です。

積み木は、(行 . 列)という整数のペアで表しています。

探索は、DFSで、回転、反転をした積み木をテーブルのすべての位置に置くことを順に試しています。

# Schemeの練習として書いてみました。あまりきれいに書けている気がしません。

(use util.match)
(use gauche.array)
(use srfi-1)
(use srfi-42)

(define height 4)
(define width 4)

(define mino-images
  '(("****")

    ("**"
     "**")

    ("***"
     " * ")

    ("***"
     "*  ")

    ("** "
     " **")))


;; string list -> point list
(define (mino-image->points mino-image)
  (append-map (lambda (row s)
                (filter-map (lambda (col)
                              ;; asterisk -> (row . col)
                              (match (string-ref s col)
                                [#\*    (cons row col)]
                                [#\space #f]))
                            (iota (string-length s) 0)))
              (iota (length mino-image) 0)
              mino-image))

(define (rotate mino) (map (match-lambda [(row . col) (cons col (- row))]) mino))
(define (flip mino) (map (match-lambda [(row . col) (cons col row)]) mino))

;; rotate, flip and delete duplicates
(define (mino-patterns mino)
  (define (rotate-n mino n)
    (let f ([i 0] [m mino] [l '()])
      (if (< i n) (f (+ i 1) (rotate m) (cons m l)) l)))
  (delete-duplicates (append (rotate-n mino 4) (rotate-n (flip mino) 4))))

;;; Table

(define (make-tbl row col) (make-array (shape 0 row 0 col) #f))
(define tbl-ref array-ref)
(define tbl-set  (cut array-set! <> <> <> #t))
(define tbl-unset  (cut array-set! <> <> <> #f))

(define (tbl-encode tbl)
  (fold (lambda (c n) (match c [#t (+ (* 2 n) 1)] [#f (* 2 n)]))
        0
        (array->list tbl)))

(define (tbl-put tbl mino row col)
  (define (valid? tbl mino row col)
    (every (match-lambda [(d-row . d-col)
                          (let ([r (+ row d-row)] [c (+ col d-col)])
                            (and (>= r 0) (< r height)
                                 (>= c 0) (< c width)
                                 (not (tbl-ref tbl r c))))])
           mino))
  (and (valid? tbl mino row col)
      (let ()
        (for-each (match-lambda [(d-row . d-col)
                                 (tbl-set tbl (+ row d-row) (+ col d-col))])
                  mino)
        #t)))
(define (tbl-unput-mino tbl mino row col)
  (for-each (match-lambda [(d-row . d-col)
                           (tbl-unset tbl (+ row d-row) (+ col d-col))])
            mino))

;; for debug
(define (tbl-dump tbl)
  (format #t "--~%")
  (do-ec (: row 0 height)
         (begin
           (do-ec (: col 0 width)
                  (format #t "~a" (if (tbl-ref tbl row col) #\* #\space)))
           (format #t "~%"))))

(define (dfs ht tbl mino-list)
  (or (null? mino-list)
      (let* ([e (tbl-encode tbl)])
        (and (not (hash-table-get ht e #f))
            (let ()
              (hash-table-put! ht e #t)
              (and (not (null? mino-list))
                   (any?-ec (:list m (mino-patterns (car mino-list)))
                            (: row 0 height) (: col 0 width)
                            (if (tbl-put tbl m row col)
                                (let1 r (dfs ht tbl (cdr mino-list))
                                  (tbl-unput-mino tbl m row col)
                                  r)
                                #f))))))))

(define all-mino-list (map mino-image->points mino-images))

(define (can-put-minos? ids)
  (format #t "~a : ~a~%"
          ids
          (if (dfs (make-hash-table) (make-tbl height width)
                   (map (lambda (id) (ref all-mino-list (- id 1))) ids))
              "ok"
              "ng")))

(define (main args)
  (can-put-minos? '(1 1 1 1))
  (can-put-minos? '(2 2 2 2))
  (can-put-minos? '(3 3 3 3))
  (can-put-minos? '(4 4 4 4))
  (can-put-minos? '(5 5 5 5))
  (can-put-minos? '(1 2 2 3))
  (can-put-minos? '(1 4 4 5))
  0) ; exit code

UTF-16をUTF-8に変換 (Nested Flatten)

Wikipedia 見つつ変換処理も書いてみました。

(use util.list)

(define (utf16-2byte->utf8 b1 b2)
  (cond
    ((and (zero? b1) (< b2 (expt 2 7))) (list b2))
    ((< b1 (expt 2 3))
      (list
        (logior #b11000000 (logand #b00011100 (ash b1 2))
                           (logand #b00000011 (ash b2 -6)))
        (logior #b10000000 (logand #b00111111 b2))))
    (else
      (list
        (logior #b11100000 (logand #b00001111 (ash b1 -4)))
        (logior #b10000000 (logand #b00111100 (ash b1 2))
                           (logand #b00000011 (ash b2 -6)))
        (logior #b10000000 (logand #b00111111 b2))))))

(define (utf16-4byte->utf8 b1 b2 b3 b4)
  (let ((bb1 (+ 1 (logior (logand #b00001100 (ash b1 2))
                          (logand #b00000011 (ash b2 -6)))))
        (bb2 (logior (logand #b11111100 (ash b2 2)) (logand #b00000011 b3)))
        (bb3 b4))
    (list
      (logior #b11110000 (ash bb1 -2))
      (logior #b10000000 (logand #b00110000 (ash bb1 4))
                         (logand #b00001111 (ash bb2 -4)))
      (logior #b10000000 (logand #b00111100 (ash bb2 2))
                         (logand #b00000011 (ash bb3 -6)))
      (logior #b10000000 (logand #b00111111 bb3)))))

(define (utf16->utf8 utf16)
  (string-join
    (map (lambda (n) (format "~8,'0b" n))
      (let loop ((ls (map (lambda (s) (string->number s 16)) (string-split utf16 #\space)))
                 (ret '()))
        (if (pair? ls)
          (if (<= #xD8 (car ls) #xDF)
            (loop (drop* ls 4) (append ret (apply utf16-4byte->utf8 (take* ls 4))))
            (loop (drop* ls 2) (append ret (apply utf16-2byte->utf8 (take* ls 2)))))
          ret)))))

Gauche は標準で UTF-8 をサポートしているので、
UCS コードポイントからバイト列への変換は Gauche に任せて楽してます :-)

gosh> (utf16->utf8 "00 41 00 42 00 43")
"01000001 01000010 01000011"
gosh> (utf16->utf8 "30 42 30 44 30 46")
"11100011 10000001 10000010 11100011 10000001 10000100 11100011 10000001 100001\
10"

(use util.match)
(use util.list)
(use srfi-1)

(define (utf16->utf8 utf16)
  (string-join
    (append-map (lambda (ucs)
                  (map (cut format "~8,'0b" <>)
                       (ucs->bytes ucs)))
                (byte-list->ucs-list
                  (map (cut string->number <> 16)
                       (string-split utf16 #\space))))))

(define (ucs->bytes ucs)
  (call-with-input-string #`",(ucs->char ucs)"
    (cut port->list read-byte <>)))

(define (byte-list->ucs-list bytes)
  (let loop ([bytes bytes] [accum '()])
    (match (take* bytes 2)
      [() (reverse accum)]
      [(hi lo) (loop (cddr bytes) (cons (+ (* 256 hi) lo) accum))]
      [else (error "error.")])))

Twitterへの投稿 (Nested Flatten)

Gauche使いました。インデントってこんなんでいいんでしょうか。Schemeはあんまり慣れていないです。

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

(define (twitte id password message)
    (http-post
        "twitter.com"
        (string-append
            "/statuses/update.xml?status="
            (uri-encode-string message :encoding "UTF-8"))
        ""
        :authorization (string-append
            "Basic "
            (base64-encode-string
                (string-append
                    id ":" password)))))

(twitte "なまえ" "パスワード" "一言")

シードを固定した乱数 (Nested Flatten)

srfi-27で.

see: SRFI 27: Sources of Random Bits

(use srfi-27)
(define (main . args)
  (define s (make-random-source))
  (begin
    (random-source-pseudo-randomize! s 1 2)
    (print ((random-source-make-reals s)))))

バイナリクロック (Nested Flatten)

(use srfi-19)

(print (regexp-replace-all*
        (let1 d (current-date)
          (format "　~5,'0b~%~6,'0b" (ref d 'hour) (ref d 'minute)))
        #/1/ "■"
        #/0/ "□"))

0->o, 1->Oです.

(use srfi-19)
(define (binary-clock)
  (define (integer->binary-string int)
    (regexp-replace-all
     #/1/
     (regexp-replace-all #/0/ (number->string int 2) "o")
     "O"))
  (let1 cur (time-utc->date (current-time))
        (format #t
                "\n ~2,'0d:~2,'0d\n~6,,,'o@a\n~6,,,'o@a"
                (date-hour cur)
                (date-minute cur)
                (integer->binary-string (date-hour cur))
                (integer->binary-string (date-minute cur)))))
(binary-clock)

リングノードベンチマーク (Nested Flatten)

#9269 は不評だったようなので、継続でコルーチンっぽいものを作って
#9266 を参考にしてやってみました。

継続を生成するのにかなり時間がかかっているようです。
$ time ./doukaku271.scm 10000 1000
./doukaku271.scm 10000 1000  43.23s user 0.36s system 98% cpu 44.303 total
$

#!/usr/bin/env gosh

(use util.queue)
(use gauche.parameter)

(define *nodes* (make-parameter #f))

(define (yield msg hop)
  (let/cc cc
    (enqueue! (*nodes*) cc)
    ((dequeue! (*nodes*)) msg hop)))

(define (make-node name)
  (lambda (msg hop)
    (let loop ([msg msg] [hop hop])
      (cond [(= hop 0) #f]
            [else
             #;(format #t "~a: ~a~%" name msg)
             (receive (msg hop) (yield msg (- hop 1))
               (loop msg hop))]))))

(define (init-nodes n)
  (*nodes* (make-queue))
  (dotimes (i n)
    (enqueue! (*nodes*) (make-node #`"N,|i|"))))

(define (run msg n m)
  (init-nodes n)
  ((dequeue! (*nodes*)) msg (* n m)))

(define (main args)
  (run "Hello, world!"
       (x->integer (car *argv*))
       (x->integer (cadr *argv*)))
  0)

ノードの実現方法に制限はないようなので、ノードをクロージャ、
メッセージの送信を手続き呼び出しとします :-)
ノードの数を決め打ちでなく、実行時に決まるようにするとちょっと
汚くなっちゃいますが、出力さえしなければかなり高速です。

N = 10000, M = 10000 で 6.50s くらいです。
$ time ./doukaku271.scm 10000 10000
./doukaku271.scm 10000 10000  6.42s user 0.05s system 97% cpu 6.619 total
$

#!/usr/bin/env gosh

(use srfi-1)

(define-macro (define-nodes n)
  (let1 p (lambda (x)
            #;`(format #t "~a: ~a~%" ',x msg)
            #f) 
    `(begin
       (define (N0 msg m)
         (unless (= m 0)
           ,(p 'N0)
           (N1 msg (- m 1))))
       ,@(map (lambda (i)
                (let ([self (string->symbol #`"N,|i|")]
                      [next (string->symbol #`"N,(remainder (+ i 1) n)")])
                  `(define (,self msg m)
                     ,(p self)
                     (,next msg m))))
              (iota (- n 1) 1)))))

(eval `(define-nodes ,(string->number (cadr *argv*)))
      (current-module))

(N0 "Hello, world!" (string->number (car *argv*)))

メソッド数の多い組み込みクラスを列挙 (Nested Flatten)

もっといい方法がありそうな気がします。

$ gosh doukaku270.scm
<top>      : 36
<class>    : 17
<generic>  :  7
<list>     :  7
<integer>  :  7
<method>   :  5
<symbol>   :  5
<string>   :  5
<regmatch> :  4
<object>   :  4
$

(use srfi-1)

(define *builtin-identifiers*
  (let1 module (find-module 'gauche)
    (filter-map
      (cut global-variable-ref module <> #f)
      (remove (cut eq? '~$ <>)
              (hash-table-map (module-table module)
                              (lambda (sym _) sym))))))

(define *builtin-classes*
  (filter (cut is-a? <> <class>) *builtin-identifiers*))

(define *builtin-generic-functions*
  (filter (cut is-a? <> <generic>) *builtin-identifiers*))

(define (direct-methods class)
  (filter-map (lambda (method)
                (let1 specs (slot-ref method 'specializers)
                  (and (member class specs)
                       method)))
              (append-map (cut slot-ref <> 'methods)
                          *builtin-generic-functions*)))

(define (main args)
  (for-each
    (lambda (x) (format #t "~10a : ~2d~%" (class-name (car x)) (cdr x)))
    (take (sort-by (map (lambda (class)
                          (cons class (length (direct-methods class))))
                        *builtin-classes*)
                   cdr
                   >)
          10))
  0)

親子のペアからツリーを構築 (Nested Flatten)

(define (gen-family-relation alst env)
  (cond ((null? alst) env)
        (else 
          (let ((node (assoc (caar alst) env)))
            (if node
              (gen-family-relation (cdr alst) (cons (append node (cdar alst))
                                                    (not-assoc (caar alst) env)))
              (gen-family-relation (cdr alst) (cons (car alst) env)))))))

(define (query s env)
  (let ((node (assoc s env)))
    (if node
      (cons (car node) (mapcar (lambda (x) (query x env)) (cdr node)))
      s)))

(define (not-assoc key alst)
  (define (not-assoc-iter alst acc)
    (cond ((null? alst) acc)
          (else (if (equal? key (caar alst))
                  (not-assoc-iter (cdr alst) acc)
                  (not-assoc-iter (cdr alst) (cons (car alst) acc))))))
  (not-assoc-iter alst ()))

(define (mapcar func alst)
  (define (iter alst acc)
    (cond ((null? alst) acc)
          (else (iter (cdr alst) (cons (func (car alst)) acc)))))
  (iter alst ()))

IPv4アドレスのマスクの変換 (Nested Flatten)

(use srfi-1)
(use util.list)

(define (mask->nbits mask)
  (count (cut eqv? #¥1 <>)
         (append-map (lambda (n) (string->list (format "~b" (string->number n))))
                     (string-split mask #¥.))))

(define (nbits->mask nbits)
  (string-join (map (lambda (bits) #`",(string->number (list->string bits) 2)")
                    (slices (take* (make-list nbits #¥1) 32 #t #¥0) 8))
               "."))

手作業Grep (Nested Flatten)

Ypsilon + GTK で書きました。リストウィジェットを使いたかったんですが、うまくいかなかったので、チェックボタン並べてます。

(import (rnrs)
        (ypsilon gtk constants)
        (ypsilon gtk init)
        (ypsilon gtk main)
        (ypsilon gtk widget)
        (ypsilon gtk window)
        (ypsilon gtk scrolled)
        (ypsilon gtk container)
        (ypsilon gtk vpaned)
        (ypsilon gtk vbox)
        (ypsilon gtk box)
        (ypsilon gtk button)
        (ypsilon gtk check)
        (ypsilon gtk toggle)
        (ypsilon gobject signal)
        (ypsilon ffi))

(gtk_init (vector (length (command-line))) (apply vector (command-line)))

(let ((window (gtk_window_new GTK_WINDOW_TOPLEVEL))
        (scrolled-window (gtk_scrolled_window_new 0 0))
        (vpaned (gtk_vpaned_new))
        (button (gtk_button_new_with_label "OUTPUT"))
        (vbox (gtk_vbox_new 0 0))
        (destroy
            (signal-callback gboolean (GtkObject* gpointer)
                (lambda (obj data)
                    (gtk_main_quit))))
        (clicked
            (signal-callback gboolean (GtkButton* gpointer)
                (lambda (button vbox)
                    (let ((out (current-output-port)))
                        (gtk_container_foreach vbox
                            (lambda (button data)
                                (when (positive? (gtk_toggle_button_get_active button))
                                    (put-string out (gtk_button_get_label button))
                                    (newline out)))
                            0))))))

    (let ((in (current-input-port)))
        (let loop ((line (get-line in)))
            (unless (eof-object? line)
                (gtk_box_pack_start vbox (gtk_check_button_new_with_label line) 0 0 0)
                (loop (get-line in)))))

    (gtk_window_set_title window "HandGrep")
    (gtk_container_set_border_width window 10)
    (gtk_window_resize window 320 240)

    (g_signal_connect window "destroy" destroy 0)
    (g_signal_connect button "clicked" clicked vbox)
    (g_signal_connect_swapped button "clicked" gtk_widget_destroy window)

    (gtk_container_add vpaned button)
    (gtk_container_add vpaned vbox)
    (gtk_scrolled_window_add_with_viewport scrolled-window vpaned)
    (gtk_container_add window scrolled-window)
    (gtk_widget_show_all window)
    (gtk_main))

ACLの制御 (Nested Flatten)

file.utilのfile-exists?をつかって存在確認し、 sys-chmodをつかって権限変更しました。

(use file.util)
(define (main args)
  (if (file-exists? "./a.txt")
      (begin (sys-chmod "./a.txt" #o600))
      (begin (touch-file "./a.txt") (sys-chmod "./a.txt" #o600))))

16進数から10進数の変換 (Nested Flatten)

Scheme にはそういう関数が用意されているのでそれを使っただけです。使える値の大きさの上限は処理系によると思います。

1
2
3

(define (hex->dec h)
  (number->string
   (string->number h 16)))

ケブンッリジ関数 (Nested Flatten)

データは標準入力から受けとります。

(use gauche.sequence)

(define (cmabrigde word)
  (rxmatch-if (#/^(.)(.+)(.)$/ word) (_ h m t)
    #`",h,(shuffle m),t"
    word))

(define (main args)
  (dolist (line (port->list read-line (current-input-port)))
    (print (string-join (map cmabrigde (string-split line " "))))))

(define *source*
  "こんにちは みなさん おげんき ですか？ わたしは げんき です。
  この ぶんしょう は いぎりす の ケンブリッジ だいがく の けんきゅう の けっか
  にんげん は もじ を にんしき する とき その さしいょ と さいご の もじさえ あっていれば
  じゅんばん は めちゃくちゃ でも ちゃんと よめる という けんきゅう に もとづいて
  わざと もじの じゅんばん を いれかえて あります。
  どうです？ ちゃんと よめちゃう でしょ？
  ちゃんと よめたら はんのう よろしく")

(use text.tree)
(use gauche.sequence)

(define (cmabrigde word)
  (let1 len (string-length word)
    (if (<= len 3)
      word
      (tree->string
        (list (string-ref word 0)
              (shuffle (substring word 1 (- len 1)))
              (string-ref word (- len 1)))))))

(define (cmabrigde-test)
  (print (string-join (map cmabrigde (string-split *source* #/\s+/)) " ")))

急勾配の判定 (Nested Flatten)

超増加列の反転かどうかを判定すればいいので、線形時間で出来ました。

(define (super-decreasing? lis)
  (let1 l (reverse lis)
        (let loop ((l l) (s 0))
          (cond ((null? l) #t)
                ((> (car l) s)
                 (loop (cdr l) (+ s (car l))))
                (else #f)))))

複素数 (Nested Flatten)

Common LispやSchemeだと問題になりませんね、これ。

Welcome to MzScheme v4.0 [cgc], Copyright (c) 2004-2008 PLT Scheme Inc.
> (+ 3+i 4-i)
7
> (- 5-9i 2+6i)
3-15i
> (* 5+3i 5+8i)
1+55i
> (/ 9-7i 9-3i)
17/15-2/5i
> (magnitude 2+3i)
3.6055512754639896

割り算の筆算 (Nested Flatten)

gauche 0.8.13です。
商の0になる桁の計算過程表示が冗長ですが・・・

gosh> (warizan 54321 5)
  10864 ... 1
  -----
5)54321
  5
  -----
   4
   0
  -----
   43
   40
  -----
    32
    30
  -----
     21
     20
  -----
      1
#<undef>

(define (warizan n m)
  (define (printf format-str . data)
    (display (apply format format-str data)))

  (define (width data)
    (string-length (format "~a" data)))

  (define (num-at n scale)
    (remainder (quotient n scale) 10))

  (define (div-num x scale)
    (let ((q (quotient x scale)))
      (string-append
       (make-string (- (+ (width n) (width m) 2)
               (width q)
               (width scale))
            #\space)
       (number->string q))))

  (define (div-line)
    (string-append
     (make-string (+ (width m) 1) #\space)
     (make-string (width n) #\-)))

  (let* ((/ quotient) (q (/ n m)))
    (printf "~a ... ~a\n~a\n~a)~a\n"
        (div-num q 1)
        (remainder n m)
        (div-line)
        m 
        n)

    (let loop ((s0 (expt 10 (- (width n) 1))))
      (let ((s1 (if (= s0 1) 1 (/ s0 10))))
    (printf "~a\n~a\n~a\n" 
        (div-num (* m s0 (num-at q s0)) s0)    
        (div-line)
        (div-num (- n (* m (/ q s0) s0)) s1))
    (if (> s0 1)
        (loop s1))))))

DouKaku?

Language detail: Scheme

Unsolved challenges

codes

Index

Feed

Other

Link

Pathtraq