M-OZ SOFT

Scheme MEMO

設定

$HOME/.guile
 (use-modules (ice-9 readline) (ice-9 slib))
 (activate-readline)

SAMPLE

再帰

階乗の計算
 (define f (lambda (n) (if (= n 0) 1 (* n (f (- n 1))))))

クイックソート

 (define qsort (lambda (x)
  (if (pair? x)
   (let lp ((pivot (car x)) (ls (cdr x)) (left '()) (right '()))
    (if (pair? ls)
     (if (< (car ls) pivot)
      (lp pivot (cdr ls) (cons (car ls) left) right)
      (lp pivot (cdr ls) left (cons (car ls) right)))
     (append (qsort left) (cons pivot (qsort right)))))
   x)))

二分探索

 (define bsearch1 (lambda (x ls)
  (let lp ((lb 0) (ub (- (length ls) 1)))
   (let ((mid (quotient (+ lb ub) 2)))
    (cond
     ((> lb ub) -1)
     ((< x (list-ref ls mid)) (lp lb (- mid 1)))
     ((< (list-ref ls mid) x) (lp (+ mid 1) ub))
     (else mid))))))

 (define bsearch2 (lambda (x ls)
  (let ((ret
   (let lp ((lb 0) (ub (- (length ls) 1)))
    (let ((mid (quotient (+ lb ub) 2)))
     (cond
      ((>= lb ub) lb)
      ((< (list-ref ls mid) x) (lp (+ mid 1) ub))
      (else (lp lb mid)))))))
   (if (= x (list-ref ls ret)) ret -1))))

URL ENCODE

(define url-encode
(lambda (str)
(let ((len (string-length str)) (result '()))
(do ((i 0 (+ i 1))) ((= i len))
(let ((c (string-ref str i)))
(cond
((char=? #\- c) (set! result (cons c result))) ;hyphen
((char=? #\. c) (set! result (cons c result))) ;period
((char=? #\_ c) (set! result (cons c result))) ;underscore
((char=? #\~ c) (set! result (cons c result))) ;tilde
((char=? #\space c) (set! result (cons #\+ result)))
((char-numeric? c) (set! result (cons c result)))
((char-alphabetic? c) (set! result (cons c result)))
(else
(set! result (cons #\% result))
(let* (
(code (char->integer c))
(c1 (quotient code 16))
(c2 (remainder code 16))
(cz (char->integer #\0))
(ca (- (char->integer #\A) 10)))
(set! result (cons (integer->char (+ (if (<= 0 c1 9) cz ca) c1)) result))
(set! result (cons (integer->char (+ (if (<= 0 c2 9) cz ca) c2)) result)))))))
(list->string (reverse result)))))

これはもうちょっと綺麗に書けるかも...。
SRFI-13 の string-for-each を使えば良いようだ。

 (use-modules (srfi srfi-13))
 (define url-encode (lambda (str)
  (string-for-each (lambda (c) (略)) str)

ファイル入力

例 1)
 (let ((port (open-input-file "filename.txt")))
  (do ((line (read-line port) (read-line port)))
   ((eof-object? line) (close-input-port port))
   (display line) (newline)))

例 2)
 (call-with-input-file "filename.txt" (lambda (port)
  (do ((line (read-line port) (read-line port)))
   ((eof-object? line))
   (display line) (newline))))

例 3)
 (call-with-input-file "filename.txt" (lambda (port)
  (let print-line ()
   (let ((line (read-line port)))
    (if (not (eof-object? line))
     (begin (display line) (newline) (print-line)))))))

read-line は SLIB の中で定義されている。
Guile では (use-modules (ice-9 rdelim)) を使う。

HTTP GET

 (define server "www.example.com")
 (define portno 80)
 (let ((so (socket PF_INET SOCK_STREAM 0)))
  (connect so AF_INET (car (vector-ref (gethost server) 4)) portno)
  (display "GET / HTTP/1.1\r\nHost: www.example.com\r\n\r\n" so)
  (do ((line (read-line so) (read-line so)))
   ((eof-object? line) (close-port so))
   (display line) (newline)))

Guile Gnome

例 1)
(use-modules (gnome gtk))
 (define (app)
  (let* ((window (make <gtk-window> #:type 'toplevel))
   (button (make <gtk-button> #:label "Hello, World!")))
  ;;(gtk-container-set-border-width window 10)
  ;;(gobject-set-property window 'border-width 10)
  (set window 'border-width 10)
  ;;(gtk-container-add window button)
  (add window button)
  ;;(gtype-instance-signal-connect button 'clicked (lambda (b) (gtk-main-quit)))
  (connect button 'clicked (lambda (b) (gtk-main-quit)))
  ;;(gtk-widget-show-all window)
  (show-all window)
  (gtk-main)))
 (app)

Guile 拡張モジュールの作り方

#かきかけ#

cat libguile-myso.c

#include <libguile.h>
SCM myfunc(SCM x){
 /* 数値を返す例 Ver1.6 */
 return scm_int2num(0);
 /* 文字列を返す例 Ver1.6 */
 return scm_makfrom0str("TEST");
}
void init_myso(){
 scm_c_define_gsubr("myfunc",1,0,0,myfunc);
 /* scm_c_make_gsubr と scm_define の組み合わせでも良い */
}

shell$ gcc -shared -o libguile-myso.so -fPIC libguile-myso.c
shell$ guile
guile> (load-extension "libguile-myso" "init_myso")
guile> (myfunc 0)

cat /usr/local/share/guile/test/mymod.scm

(define-module (test mymod))
(export myfunc)
(load-extension "libguile-myso" "init_myso")

shell$ guile
guile> (user-modules (test mymod))
guile> (myfunc 0)

#かきかけ#

[ RETURN ]