nendo 0.3.0 → 0.3.1

data/bin/nendo

@@ -1,7 +1,38 @@
-#!/usr/local/bin/ruby -W0
+#!/usr/local/bin/ruby
 # -*- encoding: utf-8 -*-
 #
-# Nendo:   "Nendo is a diarect of Lisp."
+# nendo  -  "interpretter main program"
+#  
+#   Copyright (c) 2000-2010  Kiyoka Nishiyama  <kiyoka@sumibi.org>
+#   
+#   Redistribution and use in source and binary forms, with or without
+#   modification, are permitted provided that the following conditions
+#   are met:
+#   
+#   1. Redistributions of source code must retain the above copyright
+#      notice, this list of conditions and the following disclaimer.
+#  
+#   2. Redistributions in binary form must reproduce the above copyright
+#      notice, this list of conditions and the following disclaimer in the
+#      documentation and/or other materials provided with the distribution.
+#  
+#   3. Neither the name of the authors nor the names of its contributors
+#      may be used to endorse or promote products derived from this
+#      software without specific prior written permission.
+#  
+#   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+#   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+#   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+#   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+#   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+#   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
+#   TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+#   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+#   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+#   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+#   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+#  
+#  $Id: 
 #
 require 'nendo'
 require 'getoptlong'

data/example/cgi/dekamoji.cgi

@@ -4,32 +4,19 @@
 
 (load-library "text/html-lite")
 (load-library "text/tree")
+(load-library "debug/syslog")
 (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))))
+;; ------ Please edit for your site -------
+(define fontbase "/usr/local/lib/IPAfont-0302/")
+;; ----------------------------------------
 
+(define font-list `(
+                    ("1" "ゴシック" ,(+ fontbase "ipagp.ttf"))
+                    ("2" "明朝"     ,(+ fontbase "ipamp.ttf"))
+                    ))
+(define default-fonttype 2)
 
 (define default-wording "デカ文字")
 (define default-size    2)
@@ -40,16 +27,45 @@
                     (4 . "サイズ特大")
                     ))
 
+(define (response-dekamoji str pointsize fontpath)
+  (let* ((font-dots pointsize)
+         (margin     (* pointsize 0.3))
+         (tmp-image  (Magick::Image.new 1 1))
+         (dr         (Magick::Draw.new)))
+    (set! dr.font      fontpath)
+    (set! dr.pointsize pointsize)
+    (set! dr.font_weight Magick::BoldWeight)
+    (set! dr.gravity Magick::CenterGravity)
+    (let* ((metrics (dr.get_multiline_type_metrics tmp-image str))
+           (image1   (Magick::Image.new  (+ metrics.width 30) (+ metrics.height 30))))
+      (set! image1.format  "PNG")
+      (set! dr.fill     "#777799")
+      (set! dr.stroke   "#8888AA")
+      (dr.annotate image1  0 0 5 5 str)
+      (let* ((image2 (image1.blur_channel 0 3 Magick::AllChannels)))
+        (set! dr.fill   "#111111")
+        (set! dr.stroke "#606060")
+        (dr.annotate image2  0 0 0 0 str)
+        (image2.to_blob)))))
+
 
 (define (top-page params)
+  (define (calc-limit min val max)
+    (let* ((val (if (< val min) min val))
+           (val (if (< max val) max val)))
+      val))
+
   (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)))
+                      default-wording))
+         (fonttype (if (hash-table-exist? params "type")
+                       (to-i (car (to-list (hash-table-get params "type"))))
+                       default-fonttype)))
+    (let* ((size      (calc-limit 1 size     (length size-list)))
+           (fonttype  (calc-limit 1 fonttype (length font-list))))
       `(
         ,(html-doctype)
         ,(html:head
@@ -60,9 +76,10 @@
                     (html:p
                      "下記に文章を入れて『画像化』ボタンを押して下さい")
                     (html:form
-                     :method "GET"
+                     :method "POST"
                      :action "./dekamoji.cgi"
-                     (html:input :name "w"       :type "text" :cols 140 :value wording)
+                     (html:input :name "w"       :type "text" :size 60 :value wording)
+                     (html:br)
                      (map
                       (lambda (x)
                         (list
@@ -72,29 +89,47 @@
                          (cdr x)))
                       size-list)
                      (html:br)
+                     (map
+                      (lambda (x)
+                        (list
+                         (html:input :name "type"    :type "radio"
+                                     :value (car x)
+                                     :CHECKED (eq? (to-i (car x)) fonttype))
+                         (second x)))
+                      font-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:img :src (sprintf "./dekamoji.cgi?img=1&size=%d&type=%s&w=%s" size fonttype wording))
                     (html:hr)))))))
 
 (define fontsize-alist '(
                          ("1" . 40)
                          ("2" . 80)
                          ("3" . 160)
-                         ("4" . 260)
+                         ("4" . 320)
                          ))
 
-(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))))))
+(if #f
+    ;; testing
+    (display
+     (response-dekamoji
+      "デカ文字"
+      80
+      (+ fontbase "/IPAfont00302/ipam.ttf")))
+    ;; release
+    (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)
+               (second (assv-ref (car (to-list (hash-table-get cgi.params "type"))) font-list)))))
+            (else
+             (cgi.print
+              (cgi.header))
+             (cgi.print
+              (tree->string
+               (top-page cgi.params)))))))

data/lib/debug/syslog.nnd

@@ -0,0 +1,42 @@
+;;-*- mode: nendo; syntax: scheme -*-;;
+;;;
+;;; debug/syslog.nnd  -  #?= debug message output to syslog
+;;;
+;;;  
+;;;   Copyright (c) 2000-2010  Kiyoka Nishiyama  <kiyoka@sumibi.org>
+;;;   
+;;;   Redistribution and use in source and binary forms, with or without
+;;;   modification, are permitted provided that the following conditions
+;;;   are met:
+;;;   
+;;;   1. Redistributions of source code must retain the above copyright
+;;;      notice, this list of conditions and the following disclaimer.
+;;;  
+;;;   2. Redistributions in binary form must reproduce the above copyright
+;;;      notice, this list of conditions and the following disclaimer in the
+;;;      documentation and/or other materials provided with the distribution.
+;;;  
+;;;   3. Neither the name of the authors nor the names of its contributors
+;;;      may be used to endorse or promote products derived from this
+;;;      software without specific prior written permission.
+;;;  
+;;;   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;;;   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;;;   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;;;   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;;;   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;;;   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
+;;;   TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+;;;   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+;;;   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;;   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;;   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+;;;  
+;;;  $Id: 
+;;;
+(require "syslog")
+
+(define (debug-print-output-func str)
+  (Syslog.open)
+  (Syslog.log Syslog::LOG_WARNING "%s" (+ "Nendo: " str))
+  (Syslog.close))

data/lib/debug/syslog.nndc

@@ -0,0 +1,53 @@
+
+  callProcedure( 'require',
+      begin
+        if @global_lisp_binding.has_key?('_require') then
+          @_require
+        else raise NameError.new( "Error: undefined variable _require", "_require" ) end
+        rescue => __e ; __e.set_backtrace( ["./lib/debug/syslog.nnd:37"] + __e.backtrace ) ; raise __e
+      end    ,
+      Cell.new(
+      "syslog"
+               ))
+#--------------------
+
+  begin
+    @global_lisp_binding['_debug_MIMARKprint_MIMARKoutput_MIMARKfunc'] = true
+    @_debug_MIMARKprint_MIMARKoutput_MIMARKfunc = 
+        Proc.new { |_str| 
+            begin
+                Syslog.open(
+                  )
+              rescue => __e ; __e.set_backtrace( ["./lib/debug/syslog.nnd:40"] + __e.backtrace ) ; raise __e
+            end
+            begin
+                Syslog.log(
+                      begin
+                          Syslog::LOG_WARNING
+                        rescue => __e ; __e.set_backtrace( ["./lib/debug/syslog.nnd:41"] + __e.backtrace ) ; raise __e
+                      end                    ,
+                    "%s"                    ,
+                      callProcedure( '+',
+                          begin
+                            if @global_lisp_binding.has_key?('__PLMARK') then
+                              @__PLMARK
+                            else raise NameError.new( "Error: undefined variable __PLMARK", "__PLMARK" ) end
+                            rescue => __e ; __e.set_backtrace( ["./lib/debug/syslog.nnd:41"] + __e.backtrace ) ; raise __e
+                          end                        ,
+                          Cell.new(
+                          "Nendo: "                          ,Cell.new(
+                            begin
+                                _str
+                              rescue => __e ; __e.set_backtrace( ["./lib/debug/syslog.nnd:41"] + __e.backtrace ) ; raise __e
+                            end
+                                   )))
+                  )
+              rescue => __e ; __e.set_backtrace( ["./lib/debug/syslog.nnd:41"] + __e.backtrace ) ; raise __e
+            end
+            begin
+                Syslog.close(
+                  )
+              rescue => __e ; __e.set_backtrace( ["./lib/debug/syslog.nnd:42"] + __e.backtrace ) ; raise __e
+            end
+        }
+  end

data/lib/init.nnd

@@ -1,4 +1,38 @@
 ;;-*- mode: nendo; syntax: scheme -*-;;
+;;;
+;;; init.nnd - Nendo's init file.
+;;;  
+;;;   Copyright (c) 2000-2010  Kiyoka Nishiyama  <kiyoka@sumibi.org>
+;;;   
+;;;   Redistribution and use in source and binary forms, with or without
+;;;   modification, are permitted provided that the following conditions
+;;;   are met:
+;;;   
+;;;   1. Redistributions of source code must retain the above copyright
+;;;      notice, this list of conditions and the following disclaimer.
+;;;  
+;;;   2. Redistributions in binary form must reproduce the above copyright
+;;;      notice, this list of conditions and the following disclaimer in the
+;;;      documentation and/or other materials provided with the distribution.
+;;;  
+;;;   3. Neither the name of the authors nor the names of its contributors
+;;;      may be used to endorse or promote products derived from this
+;;;      software without specific prior written permission.
+;;;  
+;;;   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;;;   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;;;   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;;;   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;;;   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;;;   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
+;;;   TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+;;;   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+;;;   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;;   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;;   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+;;;  
+;;;  $Id: 
+;;;
 
 ;; ----------------------------------------
 ;; define
@@ -72,7 +106,10 @@
 ;; ----------------------------------------
 ;; Utility functions
 ;; ----------------------------------------
-(define list? pair?)
+(define (list? arg)
+  (if (pair? arg)
+      (list? (cdr arg))
+      (null? arg)))
 (define (even? n) (= (% n 2) 0))
 (define (odd? n) (not (= (% n 2) 0)))
 (define (zero? n) (= n 0))
@@ -244,8 +281,8 @@
                      (else (if (zero? level)
                                (cond ((eq? (car form) 'unquote) (car (cdr form)))
                                      ((eq? (car form) 'unquote-splicing)
-                                      (error "Unquote-splicing wasn't in a list:"
-                                             form))
+                                      (raise RuntimeError (+ "Error: Unquote-splicing wasn't in a list: " (write-to-string form))
+                                             (sprintf "%s:%s outside list." (*FILE*) (*LINE*))))
                                      ((and (pair? (car form))
                                            (eq? (car (car form)) 'unquote-splicing))
                                       (mappend form (car (cdr (car form)))
@@ -264,11 +301,12 @@
 
 (define unquote
   (macro (lst)
-    (error "unquote appeared outside quasiquote")))
+    (raise RuntimeError "Error: unquote appeared outside quasiquote" (sprintf "%s:%s outside quasiquote" (*FILE*) (*LINE*)))))
+
 
 (define unquote-splicing
   (macro (lst)
-    (error "unquote-splicing appeared outside quasiquote")))
+    (raise RuntimeError "Error: unquote-splicing appeared outside quasiquote" (sprintf "%s:%s outside quasiquote" (*FILE*) (*LINE*)))))
 
 
 (define when
@@ -563,11 +601,11 @@
                           ,@(cddr lst))))))))
       (cond
        ((> 2 (length lst))
-        (raise ArgumentError ". dot-operator requires 2+ arguments."))
+        (raise ArgumentError ". dot-operator requires 2+ arguments." (sprintf "%s:%s in dot-operator" (*FILE*) (*LINE*))))
        (else
         (if (symbol? (second lst))
             (generate-method-call-form lst)
-            (raise TypeError ". dot-operator requires method name as symbol.")))))))
+            (raise TypeError ". dot-operator requires method name as symbol." (sprintf "%s:%s in dot-operator" (*FILE*) (*LINE*)))))))))
 
 
 (define (with-open filename pred . lst)
@@ -631,6 +669,12 @@
 (define (hash-table-delete! h key)
   (h.delete key))
 
+(define (hash-table-push! ht key value)
+  (hash-table-put!
+   ht
+   key
+   (cons value (hash-table-get ht key '()))))
+
 (define (hash-table-keys h)
   (to-list (h.keys)))
 
@@ -647,7 +691,7 @@
 
 (define (hash-table->alist h)
   (if (not (h.is_a? Hash))
-      (raise TypeError "Error: hash-table->alist expects Hash instance.")
+      (error "Error: hash-table->alist expects Hash instance.")
       (let1 keys (hash-table-keys h)
         (map
          (lambda (key)
@@ -656,7 +700,7 @@
 
 (define (alist->hash-table alist)
   (if (not (list? alist))
-      (raise TypeError "Error: alist->hash-table expects alist.")
+      (error "Error: alist->hash-table expects alist.")
       (apply hash-table alist)))
 
 ;; ----------------------------------------
@@ -736,3 +780,11 @@
       (pp-list s 0 #f)
       (write s))
   (newline))
+
+
+;; ----------------------------------------
+;; global variables
+;; ----------------------------------------
+(define *nendo-version*
+  "0.3.1"  ;;NENDO-VERSION
+  )