言語の詳細: Scheme

カバレッジ: 87.96%
プラス評価の数
カバレッジ貢献度

未解決問題

コード

フィード

使用されているモジュール

next >>

UTF-16をUTF-8に変換 (ネスト表示 フラット表示)
Wikipedia 見つつ変換処理も書いてみました。
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
(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"
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
(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への投稿 (ネスト表示 フラット表示)
Gauche使いました。インデントってこんなんでいいんでしょうか。Schemeはあんまり慣れていないです。
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
(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 "なまえ" "パスワード" "一言")
シードを固定した乱数 (ネスト表示 フラット表示)

srfi-27で.

1
2
3
4
5
6
(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)))))
バイナリクロック (ネスト表示 フラット表示)
1
2
3
4
5
6
7
(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です.

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
(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)
リングノードベンチマーク (ネスト表示 フラット表示)
#9269 は不評だったようなので、継続でコルーチンっぽいものを作って
#9266 を参考にしてやってみました。

継続を生成するのにかなり時間がかかっているようです。
$ time ./doukaku271.scm 10000 1000
./doukaku271.scm 10000 1000  43.23s user 0.36s system 98% cpu 44.303 total
$
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
#!/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
$
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
#!/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*)))
メソッド数の多い組み込みクラスを列挙 (ネスト表示 フラット表示)
もっといい方法がありそうな気がします。

$ gosh doukaku270.scm
<top>      : 36
<class>    : 17
<generic>  :  7
<list>     :  7
<integer>  :  7
<method>   :  5
<symbol>   :  5
<string>   :  5
<regmatch> :  4
<object>   :  4
$
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
(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)
親子のペアからツリーを構築 (ネスト表示 フラット表示)
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
(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アドレスのマスクの変換 (ネスト表示 フラット表示)
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
(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 (ネスト表示 フラット表示)
Ypsilon + GTK で書きました。リストウィジェットを使いたかったんですが、うまくいかなかったので、チェックボタン並べてます。
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
(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の制御 (ネスト表示 フラット表示)

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

1
2
3
4
5
(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進数の変換 (ネスト表示 フラット表示)
Scheme にはそういう関数が用意されているのでそれを使っただけです。 使える値の大きさの上限は処理系によると思います。
1
2
3
(define (hex->dec h)
  (number->string
   (string->number h 16)))
ケブンッリジ関数 (ネスト表示 フラット表示)

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

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
(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 " "))))))
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
(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+/)) " ")))
急勾配の判定 (ネスト表示 フラット表示)

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

1
2
3
4
5
6
7
(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)))))
複素数 (ネスト表示 フラット表示)

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

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
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
割り算の筆算 (ネスト表示 フラット表示)
gauche 0.8.13です。
商の0になる桁の計算過程表示が冗長ですが・・・

gosh> (warizan 54321 5)
  10864 ... 1
  -----
5)54321
  5
  -----
   4
   0
  -----
   43
   40
  -----
    32
    30
  -----
     21
     20
  -----
      1
#<undef>
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
(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))))))
ファイルサイズの取得 (ネスト表示 フラット表示)

標準手続きだけで。

1
2
3
4
5
6
7
8
9
(import (rnrs))

(let ((fn (cadr (command-line))))
  (when (file-exists? fn)
    (display
     (bytevector-length
      (call-with-port (open-file-input-port fn)
        get-bytevector-all)))
    (newline)))
next >>

一覧

フィード

その他

リンク

Pathtraq

loading...