2016年6月8日水曜日

[OCaml]cursesで文字化け

OCamlでcursesを使ってピコピコゲームでも作ろうかと思い、以前にcursesを使ったコードを動かしてみたら、 日本語が文字化けするようになっていた。
Cライブラリのsetlocale(LC_ALL,"")を実行した後に、cursesを使えば文字化けしないことが分かった。
setlocale関数の呼び出しは ctypesを使うと簡単に呼び出すことができる。
opamでパケージが用意されているので、以下のコマンドでインストールできる。
$ opam install ctypes ctypes-foreign

コードはこちら。
open Core.Std
open Ctypes
open PosixTypes
open Foreign

let time = foreign "time" (ptr time_t @-> returning time_t)

(* char *setlocale(int category, const char *locale); *)
let setlocale = foreign "setlocale" (int @-> string @-> returning string)

let () =
  let locale_str = setlocale 6(*LC_ALL*) "" in
  let module C = Curses in
  let main_window = C.initscr () in
  let err = C.mvwaddstr main_window 10 2 "hello, world!" in
  let err = C.mvwaddstr main_window 11 2 "こんにちは、世界!" in
  let err = C.refresh () in
  Unix.sleep 5;
  C.endwin ();
  printf "locale_str=%s\n" locale_str

ビルドはお手軽なcorebuildを使った。
$ corebuild -pkg curses -pkg ctypes.foreign sample.native
Debian Jessie 64bit では、LC_ALL = 6 だったので、直接コード中に書いたが、このようなヘッダで定義されている定数はどのように定義するのが正しいのだろうか。

参考

2016年4月18日月曜日

[SICP][Lisp]遅延評価の解釈系の実装

引き続きSICPを読みながら、Common LispでLispインタープリタを作成している。
「4.2.2 遅延評価の解釈系」を参考に、遅延評価できるように修正してみた。

https://github.com/takeisa/LispInCommonLisp/tree/lazy_evaluation

ifの反対のunlessを作って試してみる。

CL-USER> (repl)
LISP>
(define (unless condition usual exceptional)
    (if condition exceptional usual))
OK
LISP> (unless (= 1 0) 'hoge (/ 1 0))
HOGE

引数の(/ 1 0)は評価しないで、'hoge を返している。


cons,car,cdrを使えるようにして、前章のストリームで作成した無限リストを作ってみようとしたが、今の実装では、Common Lispの関数をそのまま使おうとすると、全ての引数をforceするようになっているので、簡単にできない。

5章のレジスタ計算機まで、早めに進みたいので後回しにしよう。

2016年4月9日土曜日

[SICP][Lisp]Common LispでLispインタープリタを書いてみた

SICP 第4章 超言語的抽象を参考にして、Common LispでLispインタープリタを書いてみた。

ソースはこちら。
https://github.com/takeisa/LispInCommonLisp

350行程度になった。
letはまだ実装していない。
言語処理系を実装するのは楽しいなー。

動作例


※evalで評価する式をデバッグ出力している。

フィボナッチ数を求める関数を定義する。
CL-USER> (repl)

LISP> (define (fibonacci n)
    (if (<= n 1)
 n
 (+ (fibonacci (- n 2)) (fibonacci (- n 1)))))
make-lamba parameters: (N)
make-lamba body: ((IF (<= N 1)
                      N
                      (+ (FIBONACCI (- N 2)) (FIBONACCI (- N 1)))))
lambda: (LAMBDA
            ((N) (IF (<= N 1) N (+ (FIBONACCI (- N 2)) (FIBONACCI (- N 1))))))
lambda parameters: (N)
lambda body: ((IF (<= N 1)
                  N
                  (+ (FIBONACCI (- N 2)) (FIBONACCI (- N 1)))))
OK

20番目のフィボナッチ数を求める。
LISP> (fibonacci 10)
t-eval: (FIBONACCI 10)
t-eval: FIBONACCI
t-eval: 10
t-eval: (IF (<= N 1)
            N
            (+ (FIBONACCI (- N 2)) (FIBONACCI (- N 1))))
t-eval: (<= N 1)
t-eval: <=
t-eval: N
t-eval: 1
..snip..
6765

2016年3月22日火曜日

[SICP][Lisp]ストリーム

SICP 3.5 ストリーム Common Lisp で実装したので、コードを貼っておこう。

遅延ストリーム・無限ストリームを使って、エラトステネスのふるいを作成し、素数を求めた。

(defmacro stream-cons (a b)
  `(cons ,a
  (delay ,b)))

(defun stream-car (s)
  (car s))

(defun stream-cdr (s)
  (force (cdr s)))

(defmacro delay (func)
  `#'(lambda () ,func))

(defun force (delay-obj)
  (funcall delay-obj))

(defvar +stream-empty+ (delay nil))

(defun stream-null? (s)
  (eq s +stream-empty+))

(defun stream-enumerate-interval (a b)
  (format t "[~a]~%" a b)
  (if (= a b)
      +stream-empty+
      (stream-cons a
     (stream-enumerate-interval (1+ a) b))))

(defun stream-each (func s)
  (unless (stream-null? s)
    (funcall func (stream-car s))
    (stream-each func (stream-cdr s))))

(defun stream-cadr (s)
  (stream-car (stream-cdr s)))

(defun stream-caddr (s)
  (stream-car (stream-cdr (stream-cdr s))))

(defun stream-nth (n s)
  (if (= n 0)
      (stream-car s)
      (stream-nth (1- n) (stream-cdr s))))

(defun stream-integers-starting-from (n)
  (stream-cons n
        (stream-integers-starting-from (1+ n))))

(defun stream-map (func &rest ss)
  (if (null (car ss))
      +stream-empty+
      (stream-cons
       (apply func (mapcar #'car ss))
       (apply #'stream-map (cons func (mapcar #'stream-cdr ss))))))

(defun stream-filter (pred s)
  (if (stream-null? s)
      +stream-empty+
      (if (funcall pred (car s))
   (stream-cons (car s)
         (stream-filter pred (stream-cdr s)))
   (stream-filter pred (stream-cdr s)))))

(defun stream-take (s n)
  (labels ((iter (s ts n)
      (if (= n 0)
   (reverse ts)
   (iter (stream-cdr s)
         (cons (stream-car s) ts)
         (1- n)))))
    (iter s '() n)))

(defun divisible? (x y)
  (= (mod x y) 0))

(defun sieve (stream)
  (stream-cons
   (stream-car stream)
   (sieve
    (stream-filter
     #'(lambda (x) (not (divisible? x (stream-car stream))))
     (stream-cdr stream)))))

sieve関数に2から始まる整数の無限ストリームを渡すと、最初の要素の値2と、2で割れる数を除外した無限ストリームを引数とするsieve関数の結果をconsしたものとなり、素数を表す無限ストリームが得られる。


実行例

最初の10個の素数を取得する。

CL-USER> (stream-take (sieve (stream-integers-starting-from 2)) 10) 
(2 3 5 7 11 13 17 19 23 29)
おおっ。素晴しい。

1000個目の素数を取得する。

CL-USER> (stream-nth 999 (sieve (stream-integers-starting-from 2)))
7919

楽しいねー。

 

10000個目の素数を取得する。

CL-USER> (stream-take (sieve (stream-integers-starting-from 2)) 9999) 
帰ってこない...

と思ったら、SBCL(swankサーバー側)でエラーとなっていて、 ヒープを使い尽していた。

fatal error encountered in SBCL pid 26815(tid 140737295218432):
Heap exhausted, game over.

ゲームオーバー...

2016年3月19日土曜日

[SICP][Lisp]デジタル回路のシミュレータ

SCIP 3.3.4 ディジタル回路のシミュレータ をCommon Lisp で書いみたので、貼っておこう。
インバータしか作っていないけど、こういうの作っていて楽しいね。

;; SICP Circuit simulator

;;----------------------------------------
;; queue

(defun make-queue ()
  (cons '() '()))

(defun front-ptr (queue)
  (car queue))

(defun rear-ptr (queue)
  (cdr queue))

(defun set-front-ptr! (queue item)
  (rplaca queue item))

(defun set-rear-ptr! (queue item)
  (rplacd queue item))

(defun empty-queue? (queue)
  (null (front-ptr queue)))

(defun front-queue (queue)
  (if (empty-queue? queue)
      (error "FRONT called with an empty queue ~a" queue)
      (car (front-ptr queue))))

(defun insert-queue! (queue item)
  (let ((new-pair (cons item '())))
    (cond
      ((empty-queue? queue)
       (set-front-ptr! queue new-pair)
       (set-rear-ptr! queue new-pair)
       queue)
      (t
       (rplacd (rear-ptr queue) new-pair)
       (set-rear-ptr! queue new-pair)
       queue))))

(defun delete-queue! (queue)
  (cond
    ((empty-queue? queue)
     (error "DELETE! called with an empty queue ~a" queue))
    (t
     (set-front-ptr! queue (cdr (front-ptr queue)))
     queue)))

;;----------------------------------------
;; time segment

(defun make-time-segment (time queue)
  (cons time queue))

(defun segment-time (segment)
  (car segment))

(defun segment-queue (segment)
  (cdr segment))

;;----------------------------------------
;; agenda

(defun make-agenda ()
  (list 0))

(defun current-time (agenda)
  (car agenda))

(defun set-current-time! (agenda time)
  (rplaca agenda time))

(defun segments (agenda)
  (cdr agenda))

(defun set-segments! (agenda segments)
  (rplacd agenda segments))

(defun first-segment (agenda)
  (car (segments agenda)))

(defun rest-segment (agenda)
  (cdr (segments agenda)))

(defun empty-agenda? (agenda)
  (null (segments agenda)))

(defun add-to-agenda! (time action agenda)
  (labels
      ((belongs-before? (segments)
  (or (null segments)
      (< time (segment-time (car segments)))))
       (make-new-time-segment (time action)
  (let ((queue (make-queue)))
    (insert-queue! queue action)
    (make-time-segment time queue)))
       (add-to-segments! (segments)
  (if (= time (segment-time (car segments)))
      (insert-queue! (segment-queue (car segments))
       action)
      (let ((rest (cdr segments)))
        (if (belongs-before? rest)
     (rplacd segments
      (cons (make-new-time-segment time action) rest))
     (add-to-segments! rest))))))
    (let ((segments (segments agenda)))
      (if (belongs-before? segments)
   (set-segments! agenda
    (cons (make-new-time-segment time action)
          segments))
   (add-to-segments! segments)))))

(defun remove-first-agenda-item! (agenda)
  (let ((q (segment-queue (first-segment agenda))))
    (delete-queue! q)
    (if (empty-queue? q)
 (set-segments! agenda (rest-segment agenda)))))

(defun first-agenda-item (agenda)
  (if (empty-agenda? agenda)
      (error "Agenda is empty -- FIRST-AGENDA-ITEM")
      (let ((segment (first-segment agenda)))
 (set-current-time! agenda (segment-time segment))
 (front-queue (segment-queue segment)))))

;;----------------------------------------
;; simulator

(defvar *agenda* nil)

(setf *agenda* (make-agenda))

(defun after-delay (delay action)
  (add-to-agenda! (+ delay (current-time *agenda*)) action *agenda*))

(defun propagate ()
  (if (empty-agenda? *agenda*)
      'done
      (let ((first-item (first-agenda-item *agenda*)))
 (funcall first-item)
 (remove-first-agenda-item! *agenda*)
 (propagate))))

(defun call-each (procs)
  (if (null procs)
      'done
      (progn
 (funcall (car procs))
 (call-each (cdr procs)))))

(defun make-wire ()
  (let ((signal-value 0)
 (action-procs '()))
    (labels ((set-signal! (value)
        (if (= value signal-value)
     'done
     (progn
       (setf signal-value value)
       (call-each action-procs))))
      (add-action! (proc)
        (setf action-procs (cons proc action-procs))
        (funcall proc))
      (dispatch (method)
        (case method
   ('get-signal signal-value)
   ('set-signal! #'set-signal!)
   ('add-action! #'add-action!)
   (t (error "Unknown operation ~a -- WIRE" method)))))
      #'dispatch)))

(defun get-signal (wire)
  (funcall wire 'get-signal))

(defun set-signal! (wire value)
  (funcall (funcall wire 'set-signal!) value))

(defun add-action! (wire proc)
  (funcall (funcall wire 'add-action!) proc))

(defun logical-not (value)
  (cond
    ((= value 0) 1)
    ((= value 1) 0)
    (t (error "Invalid signal ~a" value))))

(defvar *inverter-delay* 2)

(defun inverter (input output)
  (add-action! input
        #'(lambda ()
     (let ((new-value (logical-not (get-signal input))))
       (after-delay *inverter-delay*
      #'(lambda ()
          (set-signal! output new-value))))))
  'ok)

(defun probe (name wire)
  (add-action! wire
        #'(lambda ()
     (format t "~a ~a ~a~%"
      (current-time *agenda*)
      name
      (get-signal wire)))))

;;----------------------------------------
;; circuit

(defparameter w1 (make-wire))
(defparameter w2 (make-wire))

(inverter w1 w2)
(probe "w1" w1)
(probe "w2" w2)

動かしてみる。

0 w1 0
0 w2 0
CL-USER> (propagate)
2 w2 1
DONE
CL-USER> (set-signal! w1 1)
2 w1 1
DONE
CL-USER> (propagate)
4 w2 0
DONE
CL-USER>

もう少しいろいろ遊びたいところだけど、先に進もう。

2016年1月30日土曜日

[Emacs] org-modeで新しいメモを追加するElisp

ここ数年、Emacsでメモをとるのに、Change Logモードを使ってきた。
メモを書きたいときに、C-x 4 a (add-change-log-entry-other-window) で 、簡単に、新しいエントリをメモの最初に追加できるので便利だった。
最近、orgモードでメモをとり始めたのだけど、長年使ってきた 新エントリの追加ができず不便だったので、作ってみた。

(global-set-key (kbd "C-x 5 a") 'insert-memo-new-headline)

(defvar *memo-file* "~/org/memo.org")

(defun insert-memo-new-headline ()
  (interactive)
  (let ((memo-buffer (find-file-noselect *memo-file*)))
    (unless (eq (current-buffer) memo-buffer)
      (when (one-window-p t)
 (split-window))
      (other-window 1)
      (switch-to-buffer memo-buffer)))
  (goto-char 0)
  (insert "\n\n")
  (goto-char 0)
  (insert "* ")
  (org-insert-time-stamp nil)
  (insert " "))

C-x 5 a で *memo-file*で指定したファイルの最初に移動し、 図のような形式で、新しいメモを追加できるようになる。



久し振りにElispのコードを書いたけど、いろいろ忘れてしまっていた...
こういうときは、るびきちさんのEmacs Lispテクニックバイブルがとても便利。