nendo 0.2.0 → 0.3.0

data/bin/nendo

@@ -1,12 +1,47 @@
 #!/usr/local/bin/ruby -W0
+# -*- encoding: utf-8 -*-
 #
-# Nendo:   "Principle of Least Surprise (for Rubyist)"
+# Nendo:   "Nendo is a diarect of Lisp."
 #
 require 'nendo'
+require 'getoptlong'
 
 def main
+  loadInit = true
   core = Nendo.new()
-  core.loadInitFile
+
+  opts = GetoptLong.new(
+                        [ '--help',          '-h', GetoptLong::NO_ARGUMENT ],
+                        [ '--no-init-file',  '-q', GetoptLong::NO_ARGUMENT ],
+                        [ '--load',          '-l', GetoptLong::REQUIRED_ARGUMENT ]
+                        ).each { |opt, arg|
+    case opt
+    when '--help'
+      puts <<-EOF
+      
+      nendo [OPTION] [script-file]
+
+      -h, --help:
+        show help
+
+      -q, --no-init-file:
+        Does not read the default initialization file.
+
+      -l, --load:
+        Does not read the default initialization file.
+
+      EOF
+    when '--no-init-file'
+      loadInit = false
+    when '--load'
+      core.load( arg )
+      STDERR.printf( "loaded file [%s]\n", arg )
+    end
+  }
+  
+  if loadInit
+    core.loadInitFile
+  end
   if 0 < ARGV.length
     core.load( ARGV[0] )
   else

data/example/cgi/dekamoji.cgi

@@ -0,0 +1,100 @@
+#!/bin/sh
+:; #-*- mode: nendo; syntax: scheme -*-;;
+:; exec /usr/local/bin/nendo $0 $*
+
+(load-library "text/html-lite")
+(load-library "text/tree")
+(require "cgi")
+(require "RMagick")
+
+(define (response-dekamoji str pointsize)
+  (let* ((font-dots pointsize)
+         (margin (* pointsize 0.3))
+         (image  (Magick::Image.new (+ (* str.size font-dots) margin) (+ font-dots margin)))
+         (imlist (Magick::ImageList.new))
+         (dr     (Magick::Draw.new)))
+    (set! image.background_color "none")
+    (set! image.format "PNG")
+    (imlist.push image)
+    ;;(set! dr.font "/Volumes/Macintosh HD/Library/Fonts/ホリデイMDJP03")
+    ;;(set! dr.font "/Volumes/Macintosh HD/Library/Fonts/みかちゃん")
+    ;;(set! dr.font "/Volumes/Macintosh HD/Library/Fonts/ヒラギノ丸ゴ ProN W4.otf")
+    ;;(set! dr.font "/Volumes/Macintosh HD/Library/Fonts/ヒラギノ明朝 Pro W6.otf")
+    (set! dr.font "/Volumes/Macintosh HD/Library/Fonts/ヒラギノ明朝 Pro W3.otf")
+    (set! dr.pointsize pointsize)
+    (set! dr.fill   "#404040")
+    (set! dr.stroke "#080808")
+    (set! dr.font_weight Magick::BoldWeight)
+    (set! dr.gravity Magick::CenterGravity)
+    (dr.annotate imlist 0 0 0 0 str)
+    (let1 blur (imlist.blur_image 1.0 1.0)
+      (blur.to_blob))))
+
+
+(define default-wording "デカ文字")
+(define default-size    2)
+(define size-list '(
+                    (1 . "サイズ小")
+                    (2 . "サイズ中")
+                    (3 . "サイズ大")
+                    (4 . "サイズ特大")
+                    ))
+
+
+(define (top-page params)
+  (let* ((size (if (hash-table-exist? params "size")
+                   (to-i (car (to-list (hash-table-get params "size"))))
+                   default-size))
+         (wording (if (hash-table-exist? params "w")
+                      (car (to-list (hash-table-get params "w")))
+                      default-wording)))
+    (let* ((size (if (> 1 size) 1 size))
+           (size (if (< (length size-list) size) (length size-list) size)))
+      `(
+        ,(html-doctype)
+        ,(html:head
+          (html:title "デカ文字作成"))
+        ,(html:body
+          (html:div :style "text-align: center; "
+                    (html:h1 "デカ文字作成")
+                    (html:p
+                     "下記に文章を入れて『画像化』ボタンを押して下さい")
+                    (html:form
+                     :method "GET"
+                     :action "./dekamoji.cgi"
+                     (html:input :name "w"       :type "text" :cols 140 :value wording)
+                     (map
+                      (lambda (x)
+                        (list
+                         (html:input :name "size"    :type "radio"
+                                     :value (car x)
+                                     :CHECKED (eq? (car x) size))
+                         (cdr x)))
+                      size-list)
+                     (html:br)
+                     (html:input :type "submit"  :value "画像化"))
+                    (html:hr)
+                    (html:img :src (sprintf "./dekamoji.cgi?img=1&size=%d&w=%s" size wording))
+                    (html:hr)))))))
+
+(define fontsize-alist '(
+                         ("1" . 40)
+                         ("2" . 80)
+                         ("3" . 160)
+                         ("4" . 260)
+                         ))
+
+(let1 cgi (CGI.new)
+  (cond ((hash-table-exist? cgi.params "img")
+         (cgi.print
+          (cgi.header "image/png"))
+         (cgi.print
+          (response-dekamoji
+           (car (to-list (hash-table-get cgi.params "w")))
+           (assv-ref (car (to-list (hash-table-get cgi.params "size")))  fontsize-alist))))
+        (else
+         (cgi.print
+          (cgi.header))
+         (cgi.print
+          (tree->string
+           (top-page cgi.params))))))

data/example/cgi/sample.cgi

@@ -0,0 +1,32 @@
+#!/bin/sh
+:; #-*- mode: nendo; syntax: scheme -*-;;
+:; exec /usr/local/bin/nendo $0 $*
+
+(load-library "text/html-lite")
+(load-library "text/tree")
+(require "cgi")
+
+(define (params-list-page cgi)
+  `(
+    ,(html-doctype)
+    ,(html:head
+      (html:title "CGI parameter list"))
+    ,(html:body
+      (html:h1 "CGI parameter list")
+      (html:table :border 1
+                  (html:tr
+                   (html:th "key")
+                   (html:th "value"))
+                  (hash-table-for-each cgi.params
+                    (lambda (key value)
+                      (html:tr
+                       (html:td key)
+                       (html:td (string-join value.to_list "/")))))))))
+                       
+
+(let1 cgi (CGI.new)
+  (cgi.print
+   (cgi.header))
+  (cgi.print
+   (tree->string
+    (params-list-page cgi))))

data/{sample → example}/fact.nnd

@@ -1,6 +1,6 @@
 #!/bin/sh
-true; #-*- mode: nendo; syntax: scheme -*-;;
-true; exec /usr/local/bin/nendo $0 $*
+:; #-*- mode: nendo; syntax: scheme -*-;;
+:; exec /usr/local/bin/nendo $0 $*
 
 ;; fact
 (define (fact n)

data/{sample → example}/fizzbuzz1.nnd

@@ -1,6 +1,6 @@
 #!/bin/sh
-true; #-*- mode: nendo; syntax: scheme -*-;;
-true; exec /usr/local/bin/nendo $0 $*
+:; #-*- mode: nendo; syntax: scheme -*-;;
+:; exec /usr/local/bin/nendo $0 $*
 
 ;; FizzBuzz write in Nendo
 (define (fizzbuzz max)

data/example/html-lite-sample.nnd

@@ -0,0 +1,51 @@
+#!/bin/sh
+:; #-*- mode: nendo; syntax: scheme -*-;;
+:; exec /usr/local/bin/nendo $0 $*
+
+(load-library "text/html-lite")
+(load-library "text/tree")
+
+(define (page-sample)
+  `(
+    ,(html:head
+      (html:title "title of page"))
+    ,(html:body
+      (html:p "これはサンプルです")
+      (html:h1 "section 1")
+      (html:h2 "section 1-2")
+      (html:table :border 1
+                  (html:tr
+                   (html:th "head1")
+                   (html:th "head2"))
+                  (html:tr
+                   (html:td "data1")
+                   (html:td "data2"))
+                  (html:tr
+                   (html:td "data3")
+                   (html:td "data4"))
+                  (html:hr)))))
+
+(write-tree
+ (page-sample))
+
+
+
+
+      
+             
+            
+
+
+
+
+
+
+
+
+            
+   
+   
+   
+    
+         
+ 

data/{sample → example}/scratch.nnd

@@ -4,8 +4,4 @@
 (enable-idebug)
 (define debug-print-length 256)
 
-"abc"
-"a\nb"
-"a\"b"
-"abc\"abc\""
-"abc\'abc\'"
+

data/lib/init.nnd

@@ -107,6 +107,8 @@
 (define (ninth lst)    (nth  8 lst))
 (define (tenth lst)    (nth  9 lst))
 
+(define (x->string object) (to-s object))
+
 ;; ----------------------------------------
 ;; basic forms
 ;; ----------------------------------------
@@ -126,7 +128,9 @@
                 (let ((condition (if (eq? 'else (car elem))
                                      true
                                      (car elem)))
-                      (body      (cdr elem))
+                      (body      (if (null? (cdr elem))
+                                     '(#t)
+                                     (cdr elem)))
                       (tmpsym    (gensym)))
                   ;;(display "CONDITION") (print condition)
                   ;;(display "BODY")      (print body)
@@ -311,6 +315,13 @@
         ;; don't touch
         `(let ,@lst))))
 
+;; ----------------------------------------
+;; errorf
+;; ----------------------------------------
+(define errorf
+  (macro (format . args)
+    `(error
+      (sprintf ,format ,@args))))
 
 ;; ----------------------------------------
 ;; List utilities imported from TinyScheme
@@ -388,6 +399,13 @@
             (filter-map pred (cdr lst))))))
 
 
+(define (find pred lst)
+  (let1 result (filter pred lst)
+    (if (null? result)
+        #f
+        (car result))))
+
+
 (define lambda
   (macro src
     (if (not (list? (cadr src)))
@@ -477,43 +495,80 @@
       (let*-expand exps body))))
 
 
+;; ----------------------------------------
+;; values
+;; ----------------------------------------
+(define (values . args)
+  (case (length args)
+    ((1)
+     (car args))
+    (else
+     (make-values args))))
+
+
+(define (call-with-values producer consumer)
+  (let ((v (producer)))
+    (if (values? v)
+        (apply consumer (values-values v))
+        (consumer v))))
+
+;; srfi-8
+(define receive
+  (macro (vars expr . body)
+    `(call-with-values
+         (lambda () ,expr)
+       (lambda ,vars ,@body))))
+
+
+;; ----------------------------------------
+;; keyword
+;; ----------------------------------------
+(define (get-keyword key kv-list . fallback)
+  (cond
+   ((or (not (list? kv-list))  (>= 2 (length kv-list)))
+    (if (null? fallback)
+        (errorf "Error: imcomplete key list: %s\n" (write-to-string kv-list))
+        (car fallback)))
+   (else
+    (let loop ((k (car kv-list))
+               (v (cadr kv-list))
+               (rest (cddr kv-list)))
+      (if (eq? k key)
+          v
+          (case (length rest)
+            ((0)
+             (if (null? fallback)
+                 (errorf "Error: value for key %s is not provided : %s\n" (write-to-string key) (write-to-string kv-list))
+                 (car fallback)))
+            ((1)
+             (errorf "Error: incomplete key list: %s\n" (write-to-string kv-list)))
+            (else
+             (loop (car rest)
+                   (cadr rest)
+                   (cddr rest)))))))))
+
 ;; ----------------------------------------
 ;; for Ruby interop
 ;; ----------------------------------------
-;; dot_operator
 (define dot-operator
   (macro lst
-    (letrec ((dot-operator-iter
+    (letrec ((generate-method-call-form
               (lambda (lst)
-                (cond
-                 ((null? lst)
-                  '())
-                 ((pair? lst)
-                  (if (eq? 'dot-operator (car lst))
-                      (intern
-                       (string-join
-                        (map
-                         (lambda (x)
-                           (if (pair? x)
-                               (to-s (dot-operator-iter x))
-                               (if (symbol? x)
-                                   (to-s x)
-                                   (error (sprintf "dot-operator requires symbol, but got %s" x)))))
-                         (cdr lst))
-                        "."))
-                      (error "dot-operator requires symbol or (. symbol symbol) form.")))
-                 (else
-                  lst)))))
-
+                (let1 tmp (gensym)
+                  (if (symbol? (first lst))
+                      `(,(string->symbol (+ (to-s (first lst)) "." (to-s (second lst))))
+                        ,@(cddr lst))
+                      `(let ((,tmp ,(first lst)))
+                         (,(string->symbol (+ (to-s tmp) "." (to-s (second lst))))
+                          ,@(cddr lst))))))))
       (cond
-       ((eq? 0 (length lst))
-        (error ". operator requires argument"))
-       ((and (eq? 1 (length lst))
-             (symbol? (car lst)))
-        (intern (+ "." (to-s (car lst)))))
+       ((> 2 (length lst))
+        (raise ArgumentError ". dot-operator requires 2+ arguments."))
        (else
-        ((dot-operator-iter
-          (cons 'dot-operator lst))))))))
+        (if (symbol? (second lst))
+            (generate-method-call-form lst)
+            (raise TypeError ". dot-operator requires method name as symbol.")))))))
+
 
 (define (with-open filename pred . lst)
   (let1 len (length lst)
@@ -538,6 +593,92 @@
         x))
 
 
+(define (cons* arg . args)
+  (if (null? args)
+      arg
+      (cons arg (apply list* args))))
+(define list* cons*)
+
+
+;; ----------------------------------------
+;; hash-table library functions
+;; ----------------------------------------
+(define (make-hash-table)
+  (Hash.new))
+
+(define (hash-table? h)
+  (h.is_a? Hash))
+
+(define (hash-table-num-entries h)
+  (h.length))
+
+(define (hash-table . kv-list)
+  (let1 h (make-hash-table)
+    (for-each
+     (lambda (entry)
+       (if (pair? (cdr entry))
+           (hash-table-put! h (car entry) (cadr entry))
+           (hash-table-put! h (car entry) (cdr  entry))))
+     kv-list)
+    h))
+
+(define (hash-table-exist? h key)
+  (h.has_key? key))
+
+(define (hash-table-clear! h)
+  (h.clear))
+
+(define (hash-table-delete! h key)
+  (h.delete key))
+
+(define (hash-table-keys h)
+  (to-list (h.keys)))
+
+(define (hash-table-values h)
+  (to-list (h.values)))
+
+(define (hash-table-map h pred)
+  (let1 keys (hash-table-keys h)
+    (map
+     (lambda (key)
+       (pred key (hash-table-get h key)))
+     keys)))
+(define hash-table-for-each hash-table-map)
+
+(define (hash-table->alist h)
+  (if (not (h.is_a? Hash))
+      (raise TypeError "Error: hash-table->alist expects Hash instance.")
+      (let1 keys (hash-table-keys h)
+        (map
+         (lambda (key)
+           (cons key (hash-table-get h key)))
+         keys))))
+
+(define (alist->hash-table alist)
+  (if (not (list? alist))
+      (raise TypeError "Error: alist->hash-table expects alist.")
+      (apply hash-table alist)))
+
+;; ----------------------------------------
+;; Ruby interop librarys
+;; ----------------------------------------
+;; I will implement in the future...
+(define export
+  (macro (name)
+    `(define ,name nil)))
+
+(define (load-library name)
+  (let* ((home (get-nendo-home))
+         (path (+ home "/" name)))
+    (cond
+     ((File.exist? (+ path ".nndc"))
+      (load-compiled-code (+ path ".nndc")))
+     ((File.exist? (+ path ".nnd"))
+      (load (+ path ".nnd")))
+     (else
+      (errorf "Error: can't load library file [%s]\n" path )))))
+
+
 ;; ----------------------------------------
 ;; Utility function for testing and debugging
 ;; ----------------------------------------