Skip to content

Instantly share code, notes, and snippets.

@torus

torus/scheme_baton.scm

Forked from gemmat/scheme_baton.scm
Created January 25, 2010 20:11
Show Gist options
  • Save torus/286191 to your computer and use it in GitHub Desktop.
Save torus/286191 to your computer and use it in GitHub Desktop.
Download ZIP
Raw
scheme_baton.scm
;; 第1回 Scheme コードバトン
;;
;; ■ これは何か？
;; Scheme のコードをバトンのように回していき面白い物ができあがるのを楽しむ遊びです。
;; 次回 Shibuya.lisp で成果を発表します。
;; Scheme 初心者のコードを書くきっかけに、中級者には他人のコードを読む機会になればと思います。
;;
;; ■ 2 つのルール
;;
;; (1)自分がこれだと思える変更をコードに加えて2日以内に次の人にまわしてください。
;; 「人に優しい」変更なら何でも良い。1文字の変更でも可。
;; 「人に優しい」とは例えば、次の人が読みやすいコードを書くなど。
;; コードを削るのもあり。
;;
;; (2)次の人にまわしコードが変更されるのを"見守る"。
;; この説明書きを含めてバトンが伝わった事を必ず確認してください。
;; 止まっていたら助けてあげてください。
;;
;; ■ バトンの回し方
;;
;; (1) 回ってきたバトンは http://gist.github.com/xxxx という URL のはずです。
;; (2) fork をクリックしてください（アカウントを持っていない人はこのとき作成します）
;; (3) edit で変更したファイルを貼り付けます。
;; (4) 自分が fork した新しい URL を回してください
;;
;;
;; ■ 良くある質問
;;
;; (a) 初心者です。参加したいけどちょっと不安です。
;; higepon がフォローしますので大丈夫です。分からない事があれば遠慮無く聞いてください。
;;
;; (b) 次にまわす人がいません
;; higepon に知らせてください。twitter, 日記のコメントなどで。
;;
;; (c) 次の人がコードを止めてしまいました
;; 残念ですが別の人にバトンを渡してください。
;;
;; (d) Mosh で動かないとダメですか？
;; いいえ。Scheme なら何でも良いです。Gauche, Ypsilon 用に書き換えるのも面白いですね。
;; そのときは起動方法の説明も変えてください。
;;
;; ■ バトンの行方を記録
;; 名前(URL)：一言
;; 1. higepon (http://d.hatena.ne.jp/higepon/): 最初はコマンドライン英単語暗記ツールでした。これが何に化けるのか楽しみ。全く別物になるかな？
;; 2. yadokarielectric (http://d.hatena.ne.jp/yad-EL/20100110/p1)
;; 3. garaemon (http://garaemon.net/wordpress/?p=200)
;; 4. yshigeru (http://d.hatena.ne.jp/yshigeru/20100111/1263208636)
;; 5. g000001 (http://cadr.g.hatena.ne.jp/g000001/)
;; 6. masa.edw (http://d.hatena.ne.jp/masa_edw/20100113/1263396668)
;; 7. leque (http://d.hatena.ne.jp/leque/20100114/p1)
;; 8. emasaka (http://emasaka.blog65.fc2.com/blog-entry-700.html)
;; 9. kazu634 (http://d.hatena.ne.jp/sirocco634/20100117#1263736737)
;; 10. naoya_t (http://blog.livedoor.jp/naoya_t/): 改めてGaucheとmoshの共存を目指しました。
;; 11. snmsts (http://twitter.com/snmsts/) windowsのmoshでpdcursesをimportしてエラーをおこさずに動いてはいる…単語表示さない…48時間過ぎたorz
;; 12. Gemma (http://d.hatena.ne.jp/Gemma/20100124/1264344621) CGIにしました
;; =================================================================================================================================================
;; これより下がコードとその説明 - 変更・削除歓迎
;; =================================================================================================================================================
;; ■英単語暗記補助CGI
;; 5種類のWeb APIを提供します。レスポンスはXMLです。
;; word.cgi?q=3 IDが3の問題データ
;; word.cgi?q=3&a=y IDが3の問題データの正答率を更新する
;; word.cgi?r=5 正答率下位5個の問題ランキングデータ
;; word.cgi?w=apple&m=ringo 英単語apple、その意味ringoを、辞書に追加する
;; word.cgi おすすめの出題順をカンマ区切りで
;; ■動作方法
;; Gauche (0.9) で動作します。(http://practical-scheme.net/gauche/index-j.html)
;; 辞書ファイルはwords.txtというファイル名で、CGIと同じファイルパスに置いてください。
;;
;; ■辞書ファイルの例
;; http://gist.github.com/285224
#!/usr/local/bin/gosh
(use srfi-1)
(use util.list)
(use util.match)
(use www.cgi)
(use text.tree)
(use text.html-lite)
(use sxml.serializer)
;; 辞書ファイルのパス(文字列)
(define-constant quizzes-file "words.txt")
;; 辞書ファイルに登録できる英単語の上限(整数)
(define-constant quizzes-max-limit 500)
;; SXMLをXMLに変換してCGIの出力にする
(define (cgi-output-sxml->xml sxml)
(write-tree `(,(cgi-header :content-type "text/html;charset=utf-8")))
(srl:parameterizable
sxml
(current-output-port)
'(method . xml) ; XML
'(indent . #f) ; no indent
'(omit-xml-declaration . #t) ; append the XML declaretion
'(standalone . yes) ; add "standalone" declaretion
'(version . "1.0")))
;; 例外メッセージをSXMLにする
(define (cgi-on-error e)
`(error ,(html-escape-string (slot-ref e 'message))))
(define (main args)
(cgi-main
(lambda (params)
(let1 quizzes (load-quizzes quizzes-file)
;; クエリパラメータ
;; q は問題ID(整数)
;; a はユーザの答(文字列)
;; r は正答率下位r個(整数)
;; w は単語(文字列)
;; m は意味(文字列)
;; mode はモード(view: ウェブブラウザ向けHTML&JavaScriptの出力)
(or (and-let* ((q (cgi-get-parameter "q" params :default #f :convert x->integer)))
(or (and-let* ((a (cgi-get-parameter "a" params :default #f :convert x->string)))
;; q&aのとき、問題へのユーザの答を辞書ファイルに記録する
(save-answer quizzes q a))
;; qのとき、問題を返す
(make-quiz quizzes q)))
(and-let* ((r (cgi-get-parameter "r" params :default #f :convert x->integer)))
;; rのとき、正答率下位r個のランキングを返す
(make-ranking quizzes r))
;; w&m のとき、新しい英単語とその意味を辞書ファイルに追加する
(and-let* ((w (cgi-get-parameter "w" params :default #f :convert x->string))
(m (cgi-get-parameter "m" params :default #f :convert x->string)))
(add-new-word quizzes w m))
;; mode=view のとき、トップページのHTMLを出力する
(and-let* ((mode (cgi-get-parameter "mode" params :default #f :convert x->string)))
(case (string->symbol mode)
((view) (output-for-browser))
(else (error "invalid mode"))))
;; 何もないとき、おすすめの出題順を返す
(make-order quizzes))))
:output-proc cgi-output-sxml->xml
:on-error cgi-on-error
))
;; 辞書ファイルの形式Dは
;; W := (word meaning) | (word meaning ok-count ng-count)
;; D := (W ...)
;; load-quizzes: 辞書ファイルのパス(文字列) -> 問題リスト
(define (load-quizzes file)
(map (match-lambda
((word mean)
(list (x->string word) (x->string mean) 0 0))
((word mean ok ng)
(list (x->string word) (x->string mean) (x->integer ok) (x->integer ng))))
(call-with-input-file file read)))
;;make-quiz : 問題リスト -> 問題ID(整数) -> 問題データのSXML
(define (make-quiz quizzes nth)
(guard (e (else `(quiz (word "undefined") (mean "undefined"))))
(match (list-ref quizzes nth)
((word mean ok ng)
`(quiz (@ (id ,nth))
(word ,word)
(mean ,mean)
(ok ,ok)
(ng ,ng))))))
;;save-answer : 問題リスト -> 問題ID(整数) -> ユーザの答(文字列) -> <success/>のSXML
(define (save-answer quizzes nth answer)
(guard (e (else `(failure)))
(match (list-ref quizzes nth)
((word mean ok ng)
(set-car!
(list-tail quizzes nth)
(case (string->symbol answer)
;; Y だったら
((y Y)
(list word mean (+ ok 1) ng))
;; N だったら
((n N)
(list word mean ok (+ ng 1)))))))
;; 正答と誤答をファイルに書き込んで記録
(call-with-output-file quizzes-file (cut write quizzes <>))
'(success)))
;; sort-quizzes : 問題リスト -> 正答率下位順にソートした(正答率 . 問題ID)ペアのリスト
(define (sort-quizzes quizzes)
(define (correctness ok ng)
(if (zero? (+ ok ng))
0
(/ ok (+ ok ng))))
(sort-by (let1 index -1
(map (match-lambda
((word mean ok ng)
(inc! index)
(cons (correctness ok ng) index)))
quizzes))
car))
;; make-ranking : 問題リスト -> 正答率下位k個(整数)まで -> 正答率下位k個のランキングのSXML
(define (make-ranking quizzes k)
`(ranking (@ (r ,k))
,@(if (negative? k)
'()
(map (lambda (x)
(make-quiz quizzes (cdr x)))
(take* (sort-quizzes quizzes) k)))))
;; add-new-word : 問題リスト -> 登録する英単語(文字列) -> 登録する英単語の意味(文字列) -> <success/>のSXML
(define (add-new-word quizzes word meaning)
(guard (e (else `(failure ,(slot-ref e 'message))))
;; 登録数を制限する
(if (< (length quizzes) quizzes-max-limit)
;; 3文字以上の英単語しか認めない
(or (and-let* ((mat (#/\w{3,}/ (html-escape-string word)))
(word (mat)))
;; 16文字未満の英単語の意味しか認めない
(if (< (string-length meaning) 16)
;; 既に登録済みの英単語は認めない
(if (not (any (lambda (x)
(string=? (car x) word))
quizzes))
(begin
(set-cdr! (last-pair quizzes) (list (list (mat) meaning)))
(call-with-output-file quizzes-file (cut write quizzes <>))
'(success))
'(failure (notuniqueword)))
'(failure (toolongmeaning))))
'(failure (irregularword)))
'(failure (toomanywords)))))
;; make-order : 問題リスト -> おすすめの出題順のSXML
(define (make-order quizzes)
;;正答率下位から先に出題することをおすすめ
`(order (@ (len ,(length quizzes)))
,(string-join (map (compose x->string cdr) (sort-quizzes quizzes))
",")))
(define (script-body)
`((function init ()
(var d = document //)
(var e = (d.createElement -> "p") //)
((d.body.appendChild -> e) //)
((e.appendChild -> (d.createTextNode -> "test")) //)
)))
(define (xml-http-request req cont))
(define (output-for-browser)
`(*TOP* (html (head (title "単語練習")
(script (@ (type "text/javascript")) ,(js (script-body))))
(body (@ (onload "init()"))
(h1 "単語練習")
))))
;; JavaScript code generator
(define-module js
(export js js-sym js-let-syms)
(use util.match)
(define (join delim lst)
(if (null? lst)
""
(if (null? (cdr lst))
(car lst)
#`",(car lst),delim,(join delim (cdr lst))")))
(define (js code)
(match code
('var "var ")
('new "new ")
('in " in ")
('return "return ")
('// ";")
('.. ".")
((? symbol? sym) (symbol->string sym))
((? number? num) (number->string num))
((? string? str) #`"\",str\"")
(`(,func -> ,args ...)
#`",(js func)(,(join \",\" (map js args)))")
((() x ...)
(js `(|(| ,x |)|)))
(`(<> ,x ...)
#`"[,(js x)]")
(`(^^ ,pairs ...)
(string-append "{"
(join "," (map (lambda (p)
(js `(,(car p) |:| ,(cadr p)))
) pairs)) "}"))
(`(if (,condition ...) ,body ...)
#`"if,(js `((() ,condition) |{| ,body |}|))")
(`(else ,body ...)
#`"else,(js `(|{| ,body |}|))")
(`(for (,stmt ...) ,body ...)
#`"for,(js `((() ,stmt) |{| ,body |}|))")
(`(while (,expr ...) ,body ...)
#`"while,(js `((() ,expr) |{| ,body |}|))")
(`(function ,(? symbol? name) (,args ...) ,body ...)
#`"function ,name(,(join \",\" args)){,(js body)}")
(`(function (,args ...) ,body ...)
#`"function(,(join \",\" args)){,(js body)}")
((terms ...)
(apply string-append (map js terms)))
))
(define (js-sym) (string->symbol (string-append "$" (symbol->string (gensym)))))
(define-syntax js-let-syms
(syntax-rules ()
((_ (vars ...) body ...)
(let ((vars (js-sym)) ...)
body ...))))
)
(import js)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment