脳汁でコードを書く

6 月 28

前回に引き続き今度はフォントの描画をしてみる

(require :cl-vectors)
(require :zpb-ttf)
(require :cl-aa-misc)
(require :cl-paths-ttf)
(require :clx)
 
(defvar *font-path* "/your/path/to/ttf/font.ttf")
(defvar *display* (xlib:open-display ""))
(defvar *root-screen* (car (xlib:display-roots *display*)))
(defvar *root-window* (xlib:screen-root *root-screen*))
 
(defvar *win* (xlib:create-window :parent *root-window*
                                  :x 0 :y 0
                                  :width 300 :height 200))
 
(defvar *gc* (xlib:create-gcontext
              :drawable *root-window*))
 
(xlib:map-window *win*)
 
(defun make-image-array (base width height)
  (let ((ret (make-array (* width height 4) :element-type '(UNSIGNED-BYTE 8)
                         :initial-element 0)))
    (let ((dims (array-dimensions base)))
      (dotimes (i (car dims))
        (dotimes (j (cadr dims))
          (setf (aref ret (+ (* (+ (* i width) j) 4) 0)) (aref base i j 0))
          (setf (aref ret (+ (* (+ (* i width) j) 4) 1)) (aref base i j 1))
          (setf (aref ret (+ (* (+ (* i width) j) 4) 2)) (aref base i j 2))
          ))
      ret)))
 
(defun test-cl-vectors (func)
  (let ((height 200)
        (width 300))
    (let ((array (make-image-array (funcall func width height) width height)))
      (let ((image (xlib:create-image :data array
                                    :depth 24
                                    :bits-per-pixel 32
                                    :width width
                                    :height height
                                    :FORMAT              :Z-PIXMAP
                                    )))
        (xlib:put-image *win*
                        *gc*
                        image
                        :x 0
                        :y 0
                        :src-x 0
                        :src-y 0
                        :width width
                        :height height
                        )
        (xlib:display-finish-output *display*)
        t))))
 
 
(defun test1 (width height)
  (zpb-ttf:with-font-loader (loader *font-path*)
    (let ((paths (paths-ttf:paths-from-string loader "Hello World!"
                                              :offset (paths-ttf::make-point 0 100)
                                              :scale-x 0.05
                                              :scale-y -0.05))
          (state (aa:make-state))
          (image (aa-misc:make-image width height #(255 255 255))))
      (let ((put-pixel (aa-misc:image-put-pixel image #(0 0 0))))
        (aa:cells-sweep (vectors::update-state state paths) put-pixel)
        image))))
 
;; (test-cl-vectors #'test1)

こんな感じ

Hello World

Hello World

未分類 No Comments

6 月 28

cl-vectorsを利用したいのでその第一段.

cl-vectorsのチュートリアルはこちら.

(require :cl-vectors)
(require :cl-aa-misc)
(require :clx)
 
(defvar *display* (xlib:open-display ""))
(defvar *root-screen* (car (xlib:display-roots *display*)))
(defvar *root-window* (xlib:screen-root *root-screen*))
 
(defvar *win* (xlib:create-window :parent *root-window*
                                  :x 0 :y 0
                                  :width 300 :height 200))
 
(defvar *gc* (xlib:create-gcontext
              :drawable *root-window*))
 
(xlib:map-window *win*)
 
(defun make-simple-image-array ()
  (let ((height 200)
        (width 300))
    (let ((image (let ((state (aa:make-state)))
                   (aa:line-f state 200 50 250 150)
                   (aa:line-f state 250 150 50 100)
                   (aa:line-f state 50 100 200 50)
                   (let* ((image (aa-misc:make-image width height #(255 255 255)))
                          (put-pixel (aa-misc:image-put-pixel image #(0 0 0))))
                     (aa:cells-sweep state put-pixel)
                     image))))
      image)))
 
(defun make-image-array (base width height)
  (let ((ret (make-array (* width height 4) :element-type '(UNSIGNED-BYTE 8)
                         :initial-element 0)))
    (let ((dims (array-dimensions base)))
      (dotimes (i (car dims))
        (dotimes (j (cadr dims))
          (setf (aref ret (+ (* (+ (* i width) j) 4) 0)) (aref base i j 0))
          (setf (aref ret (+ (* (+ (* i width) j) 4) 1)) (aref base i j 1))
          (setf (aref ret (+ (* (+ (* i width) j) 4) 2)) (aref base i j 2))
          ))
      ret)))
 
(defun test-cl-vectors (func)
  (let ((height 200)
        (width 300))
    (let ((array (make-image-array (funcall func width height) width height)))
      (let ((image (xlib:create-image :data array
                                    :depth 24
                                    :bits-per-pixel 32
                                    :width width
                                    :height height
                                    :FORMAT              :Z-PIXMAP
                                    )))
        (xlib:put-image *win*
                        *gc*
                        image
                        :x 0
                        :y 0
                        :src-x 0
                        :src-y 0
                        :width width
                        :height height
                        )
        (xlib:display-finish-output *display*)
        t))))
 
(defun test1 (width height)
  (let ((image (let ((state (aa:make-state)))
                   (aa:line-f state 200 50 250 150)
                   (aa:line-f state 250 150 50 100)
                   (aa:line-f state 50 100 200 50)
                   (let* ((image (aa-misc:make-image width height #(255 255 255)))
                          (put-pixel (aa-misc:image-put-pixel image #(0 0 0))))
                     (aa:cells-sweep state put-pixel)
                     image))))
    image))
 
(defun test2 (width height)
  (let ((state (aa:make-state)))       ; create the state
  ;; the 1st triangle
  (aa:line-f state 200 50 250 150)   ; describe the 3 sides
  (aa:line-f state 250 150 50 100)   ; of the first triangle
  (aa:line-f state 50 100 200 50)
  ;; the 2nd triangle
  (aa:line-f state 75 25 10 75)      ; describe the 3 sides
  (aa:line-f state 10 75 175 100)    ; of the second triangle
  (aa:line-f state 175 100 75 25)
  (let* ((image (aa-misc:make-image width height #(255 255 255)))
         (put-pixel (aa-misc:image-put-pixel image #(0 0 0))))
    (aa:cells-sweep state put-pixel) ; render it
    image))
  )
 
(defun test3 (width height)
  (let ((state1 (aa:make-state))
        (state2 (aa:make-state)))
    ;; the 1st triangle
    (aa:line-f state1 200 50 250 150)   ; describe the 3 sides
    (aa:line-f state1 250 150 50 100)   ; of the first triangle
    (aa:line-f state1 50 100 200 50)
    ;; the 2nd triangle
    (aa:line-f state2 75 25 10 75)      ; describe the 3 sides
    (aa:line-f state2 10 75 175 100)    ; of the second triangle
    (aa:line-f state2 175 100 75 25)
    (let ((image (aa-misc:make-image width height #(255 255 255))))
      (aa:cells-sweep state1 (aa-misc:image-put-pixel image #(255 0 0)))
      (aa:cells-sweep state2 (aa-misc:image-put-pixel image #(0 0 255)))
      image)))
 
;; (test-cl-vectors #'test1)
;; (test-cl-vectors #'test2)
;; (test-cl-vectors #'test3)

こんな感じ.

tutorial 1

tutorial 1

tutorial 2

tutorial 2
tutorial 3

tutorial 3

#3Aのベクトルを#1Aにするところがださい.

未分類 No Comments

6 月 21

test from kaku.app

icon6 月 21st, 2009

テストです

未分類 No Comments

6 月 21

okra on mac

icon6 月 21st, 2009

okraがmacで動いたのでメモ.

  • mac用のOgreSDKを落として, OgreSDK/Dependencies以下のframeworkを/Library/Frameworks以下にコピーする
  • okra-1.6.2.1a1/libokra/srcの*.hにCarbon/Carbon.hを追加する
// for mac
 
#include <Carbon/Carbon.h>
  • 以下のようなMakefileを作る
CXX     = g++
RM      = rm -f
CFLAGS  = -I/Library/Frameworks/Ogre.framework/Headers \
          -I/Library/Frameworks/CEGUI.framework/Headers
LDFLAGS = -framework Ogre -framework Cg -framework CEGUI
SHARED  = -dynamiclib
CXXSRC  = ogre-camera.cpp ogre-entity.cpp ogre-light.cpp ogre-manual-object.cpp \
          ogre-node.cpp ogre-overlay-element.cpp ogre-overlay-manager.cpp \
	  ogre-overlay.cpp ogre-plane.cpp ogre-render-window.cpp \
	  ogre-resource-group-manager.cpp ogre-root.cpp \
	  ogre-scene-manager.cpp ogre-scene-node.cpp ogre-timer.cpp \
	  ogre-viewport.cpp ogre-window-event-utilities.cpp
OBJS    = $(subst .cpp,.o, $(CXXSRC))
TARGET  = ../../lib/libokra.dylib
INSTALL = cp
.PHONY: all clean
all: $(TARGET)
 
$(TARGET): $(OBJS)
	$(CXX) $(SHARED) -o $@ $^ $(LDFLAGS)
.cpp.o:
	$(CXX) -c $< $(CFLAGS)
 
clean:
	$(RM) *.o $(TARGET)
install:
	$(INSTALL) $(TARGET) /usr/local/lib/
  • src-bindings/ogre-lib.lispを編集
(define-foreign-library libokra
  (:windows "libokra.dll")
  (:darwin "libokra.dylib")
  (:unix "libokra.so")
  (t "libokra"))
  • examples/simple-okra.lispにASDFとか書いているので修正
(require 'asdf)
(asdf:operate 'asdf:load-op :okra)
  • libokra/srcでmake, make install
  • examples/simple-okra.lispなどやってみる.

未分類 No Comments

6 月 20

Ogre on mac OS X

icon6 月 20th, 2009

日本ではあんまり知られていない気がするけど, Ogreという海外ではそれなりに有名なソフトウェアがある.

実はOkraというCLのバインディングがあって, それをつかってみたいのでまずはOgreをインストールしてみた.

mac上で動かしてみたのでそのメモ.

ubuntuとかはaptで入るっぽいよ

  1. Ogreの公式からDownload->SDK->OGRE 1.6.2 SDK for Mac OS XをDL
  2. いろいろ入っているので, 適当にOgreSDKディレクトリをコピー
  3. Samples/Samples.xcodeprojを開いてbuild
  4. いくつかのサンプルはシンボリックリンクを張り替える必要がある.

ln -s -f ../OgreCEGUIRenderer.framework ./

を

ln -s -f ../../OgreCEGUIRenderer.framework ./

にする

    os x, programming No Comments

    6 月 20

    心機一転

    icon6 月 20th, 2009

    色々と思うところがあって, blogなどをまめに更新していったりしようかと思う.

    今日も明日もhogeる

    未分類 No Comments

    2 月 2

    ubuntu 8.04 on vaio type p

    icon2 月 2nd, 2009

    ubuntu 8.04ならフル解像度できるときいたので試してみた

    以下ログ

    インストール編

    • usbを作る
    • kernelが無いと怒られる
    • isolinux.cfgをsyslinux.cfgにrename.さらにsyslinux.cfgのパスを修正
    • 起動時にカーネルオプションでgeneric_all_generic_ideを追加する
    • busyboxまでしかあがらない
    • ふと日本語版のubuntu 8.04からboot usbを作ってみた
    • 日本語の場合はsyslinux.cfgもあるしパスもあっている
    • generic_all_generic_ideをつけて起動
    • 立ち上がった! 日本語チーム様々です
    • 普通にインストール.ここは男らしくvistaはバックアップとらずに全て削除
    • menu.listのカーネルオプションでgeneric_all_genetic_ideを追加

    無線LAN編

    • そのままだと無線LANを認識しないのでこまっちゃう
    • ath9kをいれる
    • ここからcompat-wireless-ath9k-2.6.24-19-generic_20080806-mactel1_i386.debをDLする
    •  $ sudo dpkg -i compat-wireless-ath9k-2.6.24-19-generic_20080806-mactel1_i386.deb
    • reboot -> 認識した!

    カーネル再コンパイル編

    • 本題ktkr
    • とりあえずネットワークが使えるようになったので
    •  sudo apt-get upgrade
    • base-fileにミスったのでここからdebを直接インストール
    • あとはここの手順にしたがってインストール
    • なんかPPAのところからlibdrm2とかもいれなきゃいけないっぽい
    • 1回目はミスったけど2回目でうまくいった.理由はよくわからない…
    • できた!

    なぜかusbのイメージ作るときに使ってたiMacがubuntuになったorz….

    10年分の伊集院のラジオが…

    後輩の卒論の手伝いでこき使われて疲れてるのかな…

    間違えてとらドラ通常版買っちゃうしな…

    追記

    カメラも使えた

    ubuntu No Comments

    1 月 17

    vaio type P店頭モデルが重いのでUSB ubuntuを試してみた

    手順

    1. まずubuntuのCDイメージをゲットする  –> ここ
    2. usbのイメージを作る 参考
    3. usbをさしてF11おしてtype Pを起動. vaioってでてからF11を押す

    ふつうに起動した

    無線はすぐ使える

    解像度がいまいち。現在奮闘中

    追記::

    psbドライバを入れればグラフィックが動く予感．だけどUSBのブートイメージを更新するのが面倒だ…

    ubuntu 3 Comments

    12 月 24

    めもめも

    Gauche-dbd-mysql-0.2.2.tgz

    すでにgaucheはいれてあるとすると

    tarボールを解凍したあとに./configureまでやってMakefileをいじる

    MYSQL_LIBSをいじる
    libgauche.soが/home/username/libにあるとして

    MYSQL_LIBS   = -L/usr/local/lib/mysql -lmysqlclient -lz -lcrypt -lm -Wl,--rpath,/home/username/lib -lgauche

    みたいにする

    ./configure --prefix=/home/username

    でよかったみたい
    欝だお

    scheme, 未分類 8 Comments

    12 月 22

    さくらインターネットでgaucheをつかってイメぴたっぽいことをしてみる

    この辺を参考にしました

    http://faq.sakuratan.com/wiki/wiki.cgi?%A5%E1%A1%BC%A5%EB#i25

    http://makingx.net/blog/2008/01/01/auto-reply-to-happy-new-year-mail/

    やるにはもちろんこの辺でも見てgaucheをインストールしてないと駄目でやんす

    まず/home/username/Mailbox/mail-account/.mailfilterを編集する
    to "| /home/username/bin/image-paste.scm | mailbot -t /home/username/misc/reply -A 'From: mail-account@username.net' /usr/sbin/sendmail -t; chmod 644 /home/username/www/images/image-paste/*; rm /home/username/misc/reply "
exit
    つぎにgaucheで適当なスクリプトを書く.

    あらためてみると結構ひどいな…

    /home/username/bin/image-paste.scm

    #!/home/username/bin/gosh
 
(use gauche.regexp)
(use gauche.charconv)
(use rfc.822)
(use rfc.mime)
(use srfi-1)
(use srfi-13)
(use srfi-19)
(use util.list)
(use text.tree)
(use text.html-lite)
(use file.util)
 
(define *reply-fname* "/home/username/misc/reply")
(define *image-dir* "/home/username/www/images/image-paste/")
(define *html-dir* "/home/username/www/images/image-paste/")
(define *url-root* "http://username.net")
(define *www-root* "/home/username/www")
 
(define (make-reply fname html-file)
  (let ((port (open-output-file fname :if-exists :append
                                      :if-does-not-exist :create)))
    (format port "automaticaly created ~A~%" html-file)
    (close-output-port port)
    #t))
 
(define (make-error-reply fname)
  (let ((port (open-output-file fname :if-exists :append
                                      :if-does-not-exist :create)))
    (format port "no image was found~%")
    (close-output-port port)
    #t))
 
(define (message-handle from subject part xport)
  (let ((image-dir *image-dir*)
        (html-dir *html-dir*)
        (reply-fname *reply-fname*))
    (let ((type (slot-ref part 'type)))
      (if (string=? type "image")
          (let ((prefix (x->string (time-second (current-time))))
                (suffix (rxmatch-after
                         (rxmatch #/\./ (cdr (assoc "name" (slot-ref part 'parameters) string=?))))))
            (let ((image-file-name (string-concatenate (list image-dir prefix "." suffix)))
                  (html-file-name (string-concatenate (list html-dir prefix ".html"))))
              ;; jpgファイルを書き出す
              (let ((oport (open-output-file image-file-name)))
                (mime-retrieve-body part xport oport)
                (close-output-port oport)
                )
              ;; 対応するhtmlファイルを作る
              (let ((tree (make-html-tree (regexp-replace-all (string->regexp *www-root*) image-file-name "") from subject)))
                (let ((oport (open-output-file html-file-name)))
                  (write-tree tree oport)
                  (close-output-port oport))
                )
              ;; 返信用の文章をつくる
              (make-reply reply-fname (regexp-replace-all (string->regexp *www-root*) html-file-name *url-root*))
              ))
        (mime-body->string part xport)))))
 
(define (make-html-tree ifname from subject)
  (list
   (html-doctype :type :html-4.01)
   (html:html
    (html:head
     (html:meta :http-equiv "Content-Type" :content "text/html; charset=UTF-8")
     (html:title (string-concatenate (map html-escape-string (list "image paste ::" subject)))))
    (html:body :lang "ja"
               :bgcolor "#ffffff"
               :text "#000000"
               :link "#0000ff"
               :vlink "#800080"
               :alink "#ff0000"
               (html:div
                (html:h3 (string-concatenate (map html-escape-string (list "from::" (regexp-replace-all #/@/ from "__at__")))))
                (html:h3 (string-concatenate (map html-escape-string (list "subject::" subject)))))
               (html:a
                :href ifname
                (html:img :border "0"
                         :src ifname
                         :alt ifname))
               )
    )))
 
(define (main args)
  (let ((port (standard-input-port)))
    (let ((headers (rfc822-read-headers port)))
      (if (mime-parse-version (rfc822-header-ref headers "mime-version"))
 
          (let ((from (rfc822-header-ref headers "from"))
                (subject (rfc822-header-ref headers "subject")))
            (mime-parse-message port headers (cut message-handle from subject <> <>))))
      ;; めんどうなのでreplyがあるかチェックしてなかったらエラー用のものを作る
      (if (not (file-is-readable? *reply-fname*))
          (make-error-reply *reply-fname*))
      (rfc822-write-headers headers)
      )))

    適当にディレクトリを変えたりすれば動くはず．

    これで.mailfilterを編集したアドレスにメールすると返信がくる．

    自分のとこだとimage __at__ garaemon.netに画像を添付してメールすると
    こんなかんじになる

    lisp, programming, scheme No Comments

    Previous Entries

    Archives

    2009 年 7 月
    月 火 水 木 金 土 日
    « 6 月    
     12345
    6789101112
    13141516171819
    20212223242526
    2728293031  

    Other

    Syndication