英語の勉強のお供に？

同僚のスクリーンセーバが英単語とその意味を表示するやつなのをみて、こういうのあると便利かなぁと思い始めたのでなんとなく似た感じのものを作ってみた。まぁそこまで似ているというほどでもないのだが、起動するとコンソールに単語の意味と例文をなんちゃってカード形式で表示するというもの。ちなみに単語はUrban Dictionaryの非公式APIを使って取得していたりするので、このスクリプトがある日突然使えなくなっても泣かないようにしないといけない。

Gistに載せたのはコピペしたものなので、色がついてたり太字になってたり下線がついてたりするのが見えないのが残念。実際にどのように見えるのかは実行すればわかるということで。

	┌─────────────────────────────────────────────────────────────────────────────┐
	│ i am disappoint │
	│ a 4chan meme. it is a series of badly drawn comics in which the son does │
	│ an act the father disapproves of, and the father says: son, i am disappoint │
	│ │
	│ Example(s) │
	│ fap fap fap- son, i am disappoint │
	│ │
	│ did you see the latest i am disappoint? it was hilarious │
	└─────────────────────────────────────────────────────────────────────────────┘
	┌─────────────────────────────────────────────────────────────────────────────┐
	│ Qunt │
	│ A cunt who believes in, pushes, or supports those who follow the QAnon │
	│ conspiracy theory and overturning democracy. Usually also a Trump supporter │
	│ who watches Fox News, OAN, or Newsmax. │
	│ │
	│ Example(s) │
	│ Marjorie Taylor Greene is a massive qunt who doesn't believe in democracy. │
	│ │
	│ See also: Kelly Loeffler, Laura Ingraham, Kayleigh McEnany │
	└─────────────────────────────────────────────────────────────────────────────┘

view raw output.txt hosted with ❤ by GitHub

	(import (rnrs)
	(getopt)
	(net http-client)
	(rfc uri-template)
	(sagittarius combinators)
	(srfi :1)
	(srfi :13)
	(srfi :18)
	(text json)
	(text json jmespath)
	(util concurrent)
	(util port))
	(define pool-config
	(http-pooling-connection-config-builder
	(connection-timeout 1000)
	(max-connection-per-route 20)
	(read-timeout 3000)
	(dns-timeout 1000)
	(time-to-live 120)))
	(define http-client
	(http:client-builder
	(connection-manager (make-http-pooling-connection-manager pool-config))))
	(define (http-get uri callback)
	(define request (http:request-builder (uri uri)))
	(future-map callback (http:client-send-async http-client request)))
	(define (string->json s) (json-read (open-string-input-port s)))
	(define (urban/random)
	(http-get "https://api.urbandictionary.com/v0/random"
	($. http:response-body utf8->string string->json)))
	(define urban/term
	(let ((template
	(parse-uri-template
	(open-string-input-port
	"https://api.urbandictionary.com/v0/define?term={term}"))))
	(lambda (term)
	(http-get (expand-uri-template template `#(("term", term)))
	($. http:response-body utf8->string string->json)))))
	(define word (jmespath "[word, definition, example]"))
	(define word-list (jmespath "list[].word"))
	(define max-thumb-up (jmespath "max_by(list, &thumbs_up).[word, definition, example]"))
	(define (describe-word l line)
	(define delta 5)
	(define (format-line wl)
	(define (upper-bound? l) (>= l (+ line delta)))
	(let loop ((wl wl) (l 0) (t '()) (r '()))
	(cond ((null? wl) (reverse! (cons (string-join (reverse! t) " ") r)))
	((upper-bound? (+ l 1 (string-length (car wl))))
	(loop wl 0 '() (cons (string-join (reverse! t) " ") r)))
	(else
	(loop (cdr wl)
	(+ l 1 (string-length (car wl))) (cons (car wl) t) r)))))
	(define (format-lines s)
	(let ((l* (map string-tokenize
	(port->string-list (open-string-input-port s)))))
	(append-map format-line l*)))
	(define (count s)
	(length (filter (lambda (c) (not (memv c '(#\[ #\])))) (string->list s))))
	(define (check l1* l2*)
	(let ((m1 (if (null? l1*) line (apply max (map count l1*))))
	(m2 (if (null? l2*) line (apply max (map count l2*)))))
	(max m1 m2)))
	(define (replace-square-blacket w)
	(let-values (((o e) (open-string-output-port)))
	(string-for-each (lambda (c)
	(case c
	((#\[) (put-string o "\x1b;[34m"))
	((#\]) (put-string o "\x1b;[0m"))
	(else (put-char o c)))) w)
	(e)))
	(define (draw-line n s e)
	(display "\x1b;(0")
	(display s)
	(do ((i 0 (+ i 1)))
	((= i n) (display e) (print "\x1b;(B"))
	(display "\x71;")))
	(define (pad m w)
	(define len (max 0 (- m (count w))))
	(do ((i 0 (+ i 1)))
	((= i len))
	(display " ")))
	(define vl "\x1b;(0\x78;\x1b;(B")
	(define (bu o)
	(display "\x1b;[1m\x1b;[4m")
	(display o)
	(display "\x1b;[0m"))
	(define (b o)
	(display "\x1b;[1m")
	(display o)
	(display "\x1b;[0m"))
	(define d display)
	(define p print)
	(define ((draw-sentence max-length) l)
	(let ((v (replace-square-blacket l)))
	(d " ") (d vl) (d " ") (d v) (pad max-length l) (p " " vl)))
	(let* ((word (car l))
	(def (format-lines (cadr l)))
	(ex (format-lines (caddr l)))
	(max-length (check def ex)))
	(d " ") (draw-line (+ max-length 2) "\x6c;" "\x6b;")
	(d " ") (d vl) (d " ") (bu word) (pad max-length word) (p " " vl)
	(for-each (draw-sentence max-length) def)
	(d " ") (d vl) (d " ") (pad max-length "") (p " " vl)
	(let ((ex "Example(s)"))
	(d " ") (d vl) (d " ") (b ex) (pad max-length ex) (p " " vl))
	(for-each (draw-sentence max-length) ex)
	(d " ") (draw-line (+ max-length 2) "\x6d;" "\x6a;")))
	(define (load-words) (future-get (future-map word-list (urban/random))))
	(define (main args)
	(with-args (cdr args)
	((period (#\p "period") #t "60")
	(width (#\w "width") #t "74")
	. ignore)
	(let loop ((words (load-words)))
	(if (null? words)
	(loop (load-words))
	(let ((word (car words)))
	(describe-word
	(future-get (future-map max-thumb-up (urban/term word)))
	(string->number width))
	(thread-sleep! (string->number period))
	(loop (cdr words)))))))

view raw urban-dictionary-card.scm hosted with ❤ by GitHub

別段特筆すべきこともないのだが、これを書くために使ったライブラリ達(当然だが全部Sagittariusに付属している)

• (net http-client): モダン(なつもり)な非同期HTTPライブラリ
• (text json jmespath): JMESPathライブラリ
• (rfc uri-template): RFC 6570準拠なURIテンプレートライブラリ
• (sagittarius combinators): コンビネーターライブラリ
• (util concurrent): 並列処理ライブラリ

処理のために書いた小道具とかもライブラリにするといいのかもと思いつつ(非同期http-getとか、コンソールの色付けとか)あまりいいアイデアもないのでとりあえず放置。