DouKaku? Language detail: Scheme

π (Nested Flatten)

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

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

タブ区切りデータの処理 (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)))))))))

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

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

see: Gauche ユーザリファレンス: 6.14 ツリーマップ

(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))))))))

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

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

see: SRFI 37

(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))

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))

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)

文字列型日時ののN秒後時間取得 (Nested Flatten)

日時の書式は ISO-8601 の「西暦-月-日T時:分:秒」形式です。時間を省略する場合には空文字列を渡すことにしてみました。

(use srfi-13)
(use srfi-19)

(define (date-ex str delta)
  (let ((t (if (string-null? str)
               (current-time time-utc)
               (date->time-utc
                (string->date str "~Y-~m-~dT~H:~M:~S")))))
    (date->string
     (time-utc->date
      (add-duration t (make-time time-duration 0 delta)))
     "~5")))

(define (main args)
  (print (date-ex (cadr args) (string->number (caddr args)))))

LL Golf Hole 8 - 横向きのピラミッドを作る (Nested Flatten)

普通ピラミッドって言ったら4角錐でしょう。

実行例:

% gosh pyramid.scm 5

※ a, sで回転、z, xでズームイン・ズームアウトします。ESC で終了です

(use gl)
(use gl.glut)

(define *height* #f)
(define *size* #f)
(define *theta* 0)

(define (init h)
  (gl-clear-color 0.0 0.0 0.0 0.0)
  (gl-shade-model GL_FLAT)
  (set! *height* h)
  (set! *size* (* h 6.0)))

(define (draw-asterisk x y z)
  (gl-push-matrix)
  (gl-translate x y z)
  (gl-begin* GL_LINES
    (for-each gl-vertex (list '#f32( 0.0  0.45) '#f32( 0.0  -0.45)
                              '#f32( 0.45 0.0 ) '#f32(-0.45  0.0)
                              '#f32( 0.3  0.3 ) '#f32(-0.3  -0.3)
                              '#f32(-0.3  0.3 ) '#f32( 0.3  -0.3))))
  (gl-pop-matrix))

(define (disp)
  (gl-clear GL_COLOR_BUFFER_BIT)
  (gl-matrix-mode GL_PROJECTION)
  (gl-load-identity)
  (gl-frustum -0.5 0.5 -0.5 0.5 1 (* 2 *size*))
  (let ((rad (* *theta* 0.0175))
        (l (/ *size* 2)))
    (glu-look-at (* l (sin rad)) 0.0 (* l (cos rad)) 0.0 0.0 0.0 0.0 1.0 0.0))
  (gl-matrix-mode GL_MODELVIEW)
  (gl-load-identity)
  (gl-color #f32(1.0 1.0 1.0))
  (do ((x (/ (- *height* 1) 2.0) (- x 1.0))
       (n 0 (+ n 1)))
      ((<= *height* n))
    (do ((y (- n) (+ y 1.0)))
        ((< n y))
      (do ((z (- n) (+ z 1.0)))
          ((< n z))
        (draw-asterisk (* x 2) y z))))
  (gl-flush))

(define (reshape w h)
  (gl-viewport 0 0 w h))

(define (keyboard key x y)
  (case key
    ((27) (exit 0))
    ((97) (dec! *theta* 10))
    ((115) (inc! *theta* 10))
    ((122) (when (< 0 *size*)
             (dec! *size* 1)))
    ((120) (inc! *size* 1)))
  (glut-post-redisplay))

(define (main args)
  (glut-init args)
  (glut-init-display-mode (logior GLUT_SINGLE GLUT_RGB))
  (glut-init-window-size 400 400)
  (glut-create-window "Pyramid")
  (init (x->integer (ref args 1)))
  (glut-display-func disp)
  (glut-reshape-func reshape)
  (glut-keyboard-func keyboard)
  (glut-main-loop)
  0)

76B。

1 2	(do[(i(-(set! (read))))]((=(inc! i)))(format #t"~v,,,'a "(- (abs i))""))

短くならないものですね。

(define (pyra n)
  (if (= n 0) 
    '() 
    (cons (make-string n #\*)(pyra (- n 1)))))
(let ((l (pyra (read))))
  (map print (append (reverse (cdr l)) l)))

(use srfi-42)

(do-ec (: i (index j) (* (read) 2) 0 -1)
  (print (make-string (min i j) #\*)))

LL Golf Hole 7 - バイト数を読みやすくする (Nested Flatten)

SLIB の format を使うと Gauche でも小数点以下桁数を指定できますね。

...それと他の皆さんのコードを見て若干変更。

(use slib)
(require 'format)
(define (main args)
    (letrec ((num (string->number (cadr args)))
        (base 1024) (prefix (string->list " KMGTPEZY"))
        (loop (lambda (n ls)
            (if (pair? ls)
                (if (< n base)
                    (format #f "~,1F~A" (exact->inexact n) (car ls))
                    (loop (/ n base) (cdr ls)))
                (format #f "~:DB" num)))))
        (display (loop num prefix))
        (newline))
    0)

車輪の再発明はしない方針で作りました。なお、*BSDでないと動かないと思います (動作はFreeBSDで確認しました。他のOSではcppflagsを変更する必要があるかも)

実行例:

% gosh human_readable.scm 123456789012345
112T

(use c-wrapper)

(c-load '("stdio.h" "stdint.h" "unistd.h" "libutil.h") 
        :cppflags "-Dlint" :libs "-lutil")

(define (main args)
  (let1 buf (make (c-array <c-char> 5))
    (humanize_number buf (c-sizeof buf) (x->integer (ref args 1)) ""
                     HN_AUTOSCALE HN_NOSPACE)
    (puts buf))
  0)

SRFI-48 や SRFI-54 を使うと小数点以下桁数を指定して出力できるようですね。

残念ながら Gauche は対応してないようなので Guile で。

(use-modules (ice-9 format))
(letrec ((num (string->number (cadr (command-line))))
    (base 1024) (prefix (string->list " KMGTPEZY"))
    (loop (lambda (m ls)
        (if (pair? ls)
            (if (< num (* m base))
                (format #f "~,1F~A" (exact->inexact (/ num m)) (car ls))
                (loop (* m base) (cdr ls)))
            (format #f "~:DB" num)))))
    (display (loop 1 prefix))
    (newline))

(let ((kibi 1024))
  (do ((n (read) (/. n kibi))
       (u '(|| k M G T) (cdr u)))
      ((< n kibi) (format #t "~A~AB~%" n (car u)) 0)))

小数点以下の桁数を固定で表示する標準的な方法が分かりません…。これだと、「10000000」が「10.MB」になってしまう。

(use srfi-42)

(print (let ((b 1000)
              (x (x->integer (read))))
          (last-ec x (:parallel (:do ((y x)) (>= y b) ((/. y b)))
                                   (: u "KMGTPEZY"))
            (format "~,,,,3a~a" (/. y b) u)))
        'B)

またクラス作るパターンでやりました。

#!/usr/bin/env gosh
(define-class <b> ()
  ((b :init-keyword :b :accessor b-b)))

(define-method write-object ((b <b>) port)
  (let* ((j (b-b b))
         (k 1000.0)
         (l '(byte k M G T P E Z Y))
         (m (min (truncate->exact (/ (log j) (log k)))
                 (- (length l) 1))))
    (if (< j k)
        (display j)
        (display (/ (truncate (* (/ j (expt k m)) 10)) 10)))
    (print (list-ref l m))))

(define (main args)
  (display "input: ")(flush)
  (print (make <b> :b (x->number(read)))))

不動点演算子 (Nested Flatten)

#5783 を Scheme で写経。

(define (fix f)
  (rec (g x) ((f g) x)))

(let ((fib (fix (lambda (f)
                  (lambda (x)
                    (if (<= x 2)
                        1
                        (+ (f (- x 1)) (f (- x 2)))))))))
  (display (map fib '(1 2 3 4 5 6 7 8 9 10)))
  (newline))

LL Golf Hole 6 - 10進数を2進数に基数変換する (Nested Flatten)

Scheme だと引き数の評価順序が規定されていないのでこっちの方が行儀がいいかな。入力は基数・数値の順に。

1	(let1 n(read)(print(number->string(read)n)))

クラス使って
やりなおし
してみました。

#!/usr/bin/env gosh

(define-class <num> ()
   ((n :init-value 0 :init-keyword :n :accessor n-num)
    (b :init-value 2 :init-keyword :b :accessor b-num)))

(define-method write-object ((n <num>) port)
  (print (number->string (n-num n) (b-num n))))

(define (main args)
  (display "input number > ")(flush)
  (print (make <num> :n (x->number(read)))))

DouKaku?

Language detail: Scheme

Unsolved challenges

codes

Index

Feed

Other

Link

Pathtraq