Easy-ISLispの簡易グラフィクス

#はじめに
コンパイラのCソース組み込み機能によりWindowsのAPIを呼び出すことも簡単にできるようになりました。以前書いてあった簡易グラフィクスをEISL用に移植しました。簡易学習環境のBabbageに同梱のEISL　ver0.78より利用可能です。吉田武先生の「素数夜曲」を楽しむことを目的としています。

#使い方
（１）グラフィクスの起動
コンパイル済みのコードをロードします。
(load "plot.o")

ロード後に(open-window)関数を呼び出すことによりグラフィクス画面が現れます。
(open-window)

（２）ウィンドウのサイズ、座標
グラフィクスウィンドウのサイズは６００＊６００です。起動時には左下の位置を原点としています。

（３）原点の移動、倍率の変更
座標は数学の考え方と同様にしています。
原点を画面中央にし第１～４象限を表示する場合には(set-origin x y)を使います。(set-origin 300 300)で原点が中央に移動します。

また、さらに(x, y) (-5 , -5) ~ (5 , 5)の範囲を描画したい場合には(set-zoom n)を使います。(set-zoom 50)でそのような表示範囲となります。

（４）タートルグラフィクス
タートルグラフィクスを使用する場合には(make-turtle)を使います。中央に亀を表す▲印が現れます。
fdで前進、bkで後退です。詳細は下記の手続きを参照してください。

（５）収録されている関数

(open-window) グラフィクス描画用のウインドウをオープンする。

(close-window) グラフィクスウインドウをクローズする。

(initialize-window) グラフィクスウインドウを初期化する。

(plot x y) 座標(x,y)に点を描画する。

(move x y) 　座標(x,y)に移動する。

(line x y)　座標(x,y)まで線を引く。

(set-origin x y) 絶対座標(x,y)を原点とする。

(set-zoom n) 拡大率をｎ倍とする。例えば(0,0)-(1,1)の範囲内を描画するのならば400倍にする。

(circle x y r) 座標(x,y)に判定rの円を描く。(circle x y r #t)現状のペンカラーで塗りつぶす。以下、rectangle,ellipse でも同様。

(rectangle x1 y1 x2 y2) 座標(x1,y1)(x2,y2)を対角線とする四角形を描く。

(ellipse x1 y2 x2 y2) 座標(x1,y1)(x2,y2)を対角線とする四角形に内接する楕円を描く。

(set-hight x) ウインドウの高さをｘとする。

(set-width x) ウインドウの幅をｘとする。

(move-window x y) ウインドウの左端を座標(x,y)に移動する。

(clear-window) ウインドウの描画を消去する。

(set-rgb r g b) 描画色をRGB(r,g,b)に設定する。

(pen-width n) ペンの描画幅をnにする。通常は１

(pen-style x) ペンの描画スタイルを設定する。ｘはスタイルを示すシンボル。
solid dash dashdot dashdotdot etc

各色を設定する。
(black)
(red)
(blue)
(green)
(yellow)
(cyan)
(magenta)
(purple)
(brown)
(orange)

(pen-color x) ペンの色を設定する。xは色のシンボル。

(make-turtle) タートルグラフィクス用の座標にし、タートルを表示する。

(home)　タートルを原点0,0の位置に戻す。そして向きを上に向かせる。

(fd n) (forward n) タートルを前にｎだけ進める。(fd n) は省略形。

(bk n) (back n) タートルを後ろにｎだけ進める。(bk n)は省略形。

(rt n) (right n) タートルを右へｎ度曲がらせる。度数法により1回転は360度。

(lt n) (left n) タートルを左へｎ度曲がらせる。度数法により1回転は360度。

(north) タートルを上へ向かせる。

(pu) (pen-up) タートルにペンを持ち上げさせる。この状態だとタートルは線を描かない。

(pd) (pen-down) タートルにペンを下ろさせる。この状態だとタートルは線を描く。

(hide-turtle) タートルを表示されないようにする。

(show-turtle) タートルを表示する。

3D

line,move,plotの３D版。

(line3D v) 引数は3次元ベクトルで与えます。

(move3D v)

(plot3D v)

(make3D) 座標を３D用に設定し座標軸を表示する。

#ISLispコード

(c-include "<windows.h>")
(c-option "-mwindows")

(c-define "UM_SetPixel" "(WM_APP + 1)")
(c-define "UM_LineTo" 	"(WM_APP + 2)")
(c-define "UM_Rectangle" "(WM_APP + 3)")
(c-define "UM_Ellipse"	"(WM_APP + 4)")
(c-define "UM_RGB"		"(WM_APP + 5)")
(c-define "UM_PatBlt"	"(WM_APP + 6)")
(c-define "UM_MoveWindow" "(WM_APP + 7)")
(c-define "UM_PenStyle"	"(WM_APP + 8)")
(c-define "UM_PenWidth"	"(WM_APP + 9)")
(c-define "UM_Turtle"	"(WM_APP + 10)")
(c-define "UM_Brush"	"(WM_APP + 11)")


(defmacro when (test :rest body)
  `(if ,test (progn ,@body)))

(defmacro unless (test :rest body)
  `(if (not ,test) (progn ,@body)))

(defun exact (x)
  (if (floatp x)
      (convert x <integer>)
      x))

(defun send-message (msg x1 x2 y1 y2)
  (c-lang "HANDLE h;")
  (c-lang "WPARAM p1;")
  (c-lang "LPARAM p2;")
  (if (not (integerp x1)) (error "send-message not integer" x1))
  (if (not (integerp x2)) (error "send-message not integer" x2))
  (if (not (integerp y1)) (error "send-message not integer" y1))
  (if (not (integerp y2)) (error "send-message not integer" y2))
  
  (c-lang "p1 = (WPARAM)((INT_MASK & X1)<<16 | (INT_MASK & X2));")
  (c-lang "p2 = (LPARAM)((INT_MASK & Y1)<<16 | (INT_MASK & Y2));")
  (c-lang "h = FindWindow(\"easyplot\",NULL);")
  (cond ((= msg 0)
         (c-lang "SendMessage(h, WM_CLOSE, p1 , p2);"))
        ((= msg 1)
         (c-lang "SendMessage(h, UM_SetPixel, p1 , p2);"))
        ((= msg 2)
         (c-lang "SendMessage(h, UM_LineTo, p1 , p2);"))
        ((= msg 3)
         (c-lang "SendMessage(h, UM_Rectangle, p1 , p2);"))
        ((= msg 4)
         (c-lang "SendMessage(h, UM_Ellipse, p1 , p2);"))
        ((= msg 5)
         (c-lang "SendMessage(h, UM_RGB, p1 , p2);"))
        ((= msg 6)
    	 (c-lang "SendMessage(h, UM_PatBlt, p1 , p2);"))
        ((= msg 7)
    	 (c-lang "SendMessage(h, UM_MoveWindow, p1 , p2);"))
        ((= msg 8)
         (c-lang "SendMessage(h, UM_PenStyle, p1 , p2);"))
        ((= msg 9)
    	 (c-lang "SendMessage(h, UM_PenWidth, p1 , p2);"))
        ((= msg 10)
    	 (c-lang "SendMessage(h, UM_Turtle, p1 , p2);"))
        ((= msg 11)
         (c-lang "SendMessage(h, UM_Brush, p1 , p2);"))
        (t (error "send-message illegal msg" msg)))
  t
)

(defglobal degree 90)
    
(defglobal turtle-x 0)
    
(defglobal turtle-y 0)
    
(defglobal prev-x 0)
    
(defglobal prev-y 0)
    
(defglobal org-x 50)
    
(defglobal org-y 510)
    
(defglobal zoom 1)
    
(defglobal top-x 0)
    
(defglobal top-y 0)
    
(defglobal height 600)
    
(defglobal width 600)
    
(defglobal show nil)
    
(defglobal down nil)
    
(defglobal pi2 (* 2 *pi*))
    
(defglobal pi *pi*)
    
(defun open-window ()
  (winexec "ewin"))
    
(defun close-window ()
  (send-message 0 0 0 0 0))
    
(defun initialize-window ()
  (move-window 0 0)
  (set-height 600)
  (set-width 600)
  (set-origin 50 510)
  (setq turtle-x 0)
  (setq turtle-y 0)
  (setq degree 90)
  (setq prev-x 0)
  (setq prev-y 0)
  (setq show nil)
  (setq down nil)
  (clear-window))
    
(defun set-zoom (n)
  (setq zoom (exact n))
  t)
    
(defun plot (x y)
  (let ((arg1 (exact (+ org-x (round (* x zoom)))))
        (arg2 (exact (- org-y (round (* y zoom))))))
    (send-message 1 arg1 arg2 0 0)))
    
(defun move (x y)
  (setq prev-x turtle-x)
  (setq prev-y turtle-y)
  (setq turtle-x x)
  (setq turtle-y y)
  t)

(defun line (x y)
  (let ((arg1 (exact (+ org-x (round (* turtle-x zoom)))))
        (arg2 (exact (- org-y (round (* turtle-y zoom)))))
        (arg3 (exact (+ org-x (round (* x zoom)))))
        (arg4 (exact (- org-y (round (* y zoom))))))
    (send-message 2 arg1 arg2 arg3 arg4)))
    
(defun ellipse (x1 y1 x2 y2 :rest c)
  (let ((arg1 (exact (+ org-x (round (* x1 zoom)))))
        (arg2 (exact (- org-y (round (* y1 zoom)))))
        (arg3 (exact (+ org-x (round (* x2 zoom)))))
        (arg4 (exact (- org-y (round (* y2 zoom))))))
    (if (null c)
        (progn (send-message 11 0 0 0 0)
               (send-message 4 arg1 arg2 arg3 arg4))
        (progn (send-message 11 1 0 0 0)
               (send-message 4 arg1 arg2 arg3 arg4)))))
    
(defun circle (x y r :rest c)
  (let ((x1 (- x r))
        (y1 (+ y r))
        (x2 (+ x r))
        (y2 (- y r)))
    (if (null c)
        (ellipse x1 y1 x2 y2)
        (ellipse x1 y1 x2 y2 (car c)))))
    
(defun non-paint ()
  (send-message 11 0 0 0 0))
    
(defun paint ()
  (send-message 11 1 0 0 0))
    
(defun rectangle (x1 y1 x2 y2 :rest c)
  (let ((arg1 (exact (+ org-x (round (* x1 zoom)))))
        (arg2 (exact (- org-y (round (* y1 zoom)))))
        (arg3 (exact (+ org-x (round (* x2 zoom)))))
        (arg4 (exact (- org-y (round (* y2 zoom))))))
    (if (null c)
        (progn (send-message 11 0 0 0 0)
               (send-message 3 arg1 arg2 arg3 arg4))
        (progn (send-message 11 1 0 0 0)
               (send-message 3 arg1 arg2 arg3 arg4)))))
    
(defun clear-window ()
  (setq show nil)
  (send-message 6 0 0 0 0))
    
(defun cls () (clear-window))
    
(defun black ()
  (send-message 5 0 0 0 0))

(defun red ()
  (send-message 5 255 0 0 0))

(defun blue ()
  (send-message 5 0 0 255 0))

(defun yellow ()
  (send-message 5 255 255 0 0))

(defun green ()
  (send-message 5 0 255 0 0))

(defun magenta ()
  (send-message 5 255 0 255 0))

(defun cyan ()
  (send-message 5 0 255 255 0))
    
(defun purple ()
  (send-message 5 128 0 128 0))
    
(defun brown ()
  (send-message 5 153 51 0 0))
    
(defun orange ()
  (send-message 5 255 102 0 0))
    
(defun pen-style (x)
  (cond ((eq x 'solid)(send-message 8 0 0 0 0))
        ((eq x 'dot)(send-message 8 1 0 0 0))
        ((eq x 'dash)(send-message 8 2 0 0 0))
        ((eq x 'dashdot)(send-message 8 3 0 0 0))
        ((eq x 'dashdotdot)(send-message 8 4 0 0 0))
        ((eq x 'null)(send-message 8 5 0 0 0))
        ((eq x 'insedeframe)(send-message 8 6 0 0 0))))
    
(defun pen-width (x)
  (send-message 9 x 0 0 0))
    
(defun pen-color (x)
  (cond ((eq x 'black)(black))
        ((eq x 'red)(red))
        ((eq x 'blue)(blue))
        ((eq x 'yellow)(yellow))
        ((eq x 'magenta)(magenta))
        ((eq x 'green)(green))
        ((eq x 'cyan)(cyan))))
    
(defun set-origin (x y)
  (setq org-x x)
  (setq org-y y)
  t)
    
(defun move-window (x y)
  (setq top-x x)
  (setq top-y y)
  (send-message 7 x y height width))
    
(defun set-height (x)
  (setq height x)
  (send-message 7 top-x top-y width x))
    
(defun set-width (x)
  (setq width x)
  (send-message 7 top-x top-y x height))
    
(defun show-turtle ()
  (unless show (display-turtle turtle-x turtle-y degree))
  (setq show t)
  t)
    
(defun hide-turtle ()
  (when show (display-turtle turtle-x turtle-y degree))
  (setq show nil)
  t)
    
(defun pen-up ()
  (setq down nil)
  t)
    
(defun pu () (pen-up))
    
(defun pen-down ()
  (setq down t)
  t)
    
(defun pd () (pen-down))
    
(defun north ()
  (when show 
    (erase-turtle turtle-x turtle-y degree)
    (reline))
  (setq degree 90)
  (when show (display-turtle turtle-x turtle-y degree))
  t)
    
(defun make-turtle ()
  (set-origin 300 300)
  (setq turtle-x 0)
  (setq turtle-y 0)
  (setq degree 90)
  (setq prev-x 0)
  (setq prev-y 0)
  (set-zoom 1)
  (show-turtle)
  (pen-down)
  t)
    
(defun home ()
  (when show (display-turtle turtle-x turtle-y degree))
  (setq turtle-x 0)
  (setq turtle-y 0)
  (setq degree 90)
  (setq prev-x 0)
  (setq prev-y 0)
  (when show (display-turtle turtle-x turtle-y degree)))
    
(defun display-turtle (x y d)
  (let ((arg1 (exact (+ org-x (round (* x zoom)))))
        (arg2 (exact (- org-y (round (* y zoom)))))
        (arg3 d)
        (arg4 0))
    (send-message 10 arg1 arg2 arg3 arg4)))
      
    
(defun forward (n)
  (let ((x (+ turtle-x (* n (cos (* pi2 (quotient degree 360))))))
        (y (+ turtle-y (* n (sin (* pi2 (quotient degree 360)))))))
    (when show (display-turtle turtle-x turtle-y degree))
    (when down (line x y))
    (move x y)
    (when show (display-turtle turtle-x turtle-y degree))))
    
(defun fd (n) (forward n))
    
(defun back (n)
  (let ((x (+ turtle-x (* (- n) (cos (* pi2 (quotient degree 360))))))
        (y (+ turtle-y (* (- n) (sin (* pi2 (quotient degree 360)))))))
    (when show (display-turtle turtle-x turtle-y degree))
    (when down (line x y))
    (move x y)
    (when show (display-turtle turtle-x turtle-y degree))))
    
(defun bk (n) (back n))
    
(defun right (n)
  (when show (display-turtle turtle-x turtle-y degree))
  (setq degree (mod (- degree n) 360))
  (when show (display-turtle turtle-x turtle-y degree))
  t)
    
(defun rt (n) (right n))
    
(defun left (n)
  (when show (display-turtle turtle-x turtle-y degree))
  (setq degree (mod (+ degree n) 360))
  (when show (display-turtle turtle-x turtle-y degree))
  t)
    
(defun lt (n) (left n))
    
;;3D
(defglobal cos-phi (cos (* 0.25 pi)))

(defglobal sin-theta (sin (* -0.75 pi)))

(defglobal cos-theta (cos (* -0.75 pi)))
    
(defglobal projection (cos (* 0.25 pi)))

(defun line3D (v)
  (let* ((x (elt v 0))
         (y (elt v 1))
         (z (elt v 2))
         (x1 (+ (* projection cos-theta cos-phi x) y))
         (y1 (+ (* projection sin-theta cos-phi x) z)))
    (line x1 y1)))

(defun move3D (v)
  (let* ((x (elt v 0))
         (y (elt v 1))
         (z (elt v 2))
         (x1 (+ (* projection cos-theta cos-phi x) y))
         (y1 (+ (* projection sin-theta cos-phi x) z)))
    (move x1 y1)))

(defun plot3D (v)
  (let* ((x (elt v 0))
         (y (elt v 1))
         (z (elt v 2))
         (x1 (+ (* projection cos-theta cos-phi x) y))
         (y1 (+ (* projection sin-theta cos-phi x) z)))
    (plot x1 y1)))

(defun make3D ()
  (let ((old-zoom zoom))
    (set-zoom 1)
    (set-origin 200 400)
    (move3D #(0 0 0))
    (black)
    (line3D #(280 0 0))
    (line3D #(0 280 0))
    (line3D #(0 0 280))
    (set-zoom old-zoom)))
    

#Windowのコード

//gcc window.c -o ewin.exe -mwindows

#include <windows.h>
#include <math.h>


#define UM_SetPixel (WM_APP + 1)
#define UM_LineTo 	(WM_APP + 2)
#define UM_Rectangle (WM_APP + 3)
#define UM_Ellipse	(WM_APP + 4)
#define UM_RGB		(WM_APP + 5)
#define UM_PatBlt	(WM_APP + 6)
#define UM_MoveWindow (WM_APP + 7)
#define UM_PenStyle	(WM_APP + 8)
#define UM_PenWidth	(WM_APP + 9)
#define UM_Turtle	(WM_APP + 10)
#define UM_Brush	(WM_APP + 11)

int dx,dy,ps=PS_SOLID,pw=1,brush=0;
BYTE r=0,g=0,b=0;
POINT turtle[] = {{0,-10.0},{10.0,0},{0,10.0}};
double PI = 3.14159265358979323846;

LRESULT CALLBACK WndProc(HWND hwnd , UINT msg , WPARAM wp , LPARAM lp) {
	HDC hdc;
    int x1,x2,y1,y2,i;
	HPEN	hpen;
	HBRUSH	hbrush;
    POINT	po[3];
    double degree,radian;
    
    x1 = HIWORD(wp);
    x2 = LOWORD(wp);
    y1 = HIWORD(lp);
    y2 = LOWORD(lp);

	switch (msg) {
    
	case WM_DESTROY:
		PostQuitMessage(0);
		return 0;
        
	case UM_SetPixel:
		hdc = GetDC(hwnd);
		SetPixel(hdc, x1 , x2, RGB(r,g,b));
		ReleaseDC(hwnd , hdc);
		return 0;
        
	case UM_LineTo:
		hdc = GetDC(hwnd);
        hpen = CreatePen(ps, pw, RGB(r,g,b));
        SelectObject(hdc, hpen);
        MoveToEx(hdc, x1 , x2, NULL);
		LineTo(hdc, y1 , y2);
        DeleteObject(hpen);
		ReleaseDC(hwnd, hdc);
		return 0;
        
    case UM_Rectangle:
    	hdc = GetDC(hwnd);
		hpen = CreatePen(ps, pw, RGB(r,g,b));
        SelectObject(hdc, hpen);
        if(brush == 1){
        	hbrush = CreateSolidBrush(RGB(r,g,b));
        	SelectObject(hdc, hbrush);
		}
    	Rectangle(hdc, x1, x2, y1 ,y2);
        DeleteObject(hpen);
        if(brush == 1)
        	DeleteObject(hbrush);
        ReleaseDC(hwnd, hdc);
		return 0;
        
    case UM_Ellipse:
    	hdc = GetDC(hwnd);
        hpen = CreatePen(ps, pw, RGB(r,g,b));
        SelectObject(hdc, hpen);
        if(brush == 1){
        	hbrush = CreateSolidBrush(RGB(r,g,b));
        	SelectObject(hdc, hbrush);
        }
    	Ellipse(hdc, x1, x2, y1 ,y2);
        DeleteObject(hpen);
        if(brush == 1)
        	DeleteObject(hbrush);
        ReleaseDC(hwnd, hdc);
		return 0;
        
    case UM_RGB:
    	r = (BYTE)x1;
        g = (BYTE)x2;
        b = (BYTE)y1;
        return 0;
        
    case UM_PatBlt:
    	hdc = GetDC(hwnd);
    	PatBlt(hdc, 0, 0, 2000 , 2000, WHITENESS);
		ReleaseDC(hwnd, hdc);
		return 0;
	
    case UM_MoveWindow:
    	MoveWindow(hwnd, x1, x2, y1, y2, TRUE);
    	return 0;
        
    case UM_PenStyle:
    	switch(x1){
        	case 0:	ps = PS_SOLID;
            		break;
            case 1:	ps = PS_DASH;
            		break;
            case 2:	ps = PS_DOT;
            		break;
            case 3:	ps = PS_DASHDOT;
            		break;
            case 4:	ps = PS_DASHDOTDOT;
            		break;
            case 5:	ps = PS_NULL;
        			break;
            case 6:	ps = PS_INSIDEFRAME;
        			break;
        }
        return 0;
        
    case UM_PenWidth:
    	pw = x1;
        return 0;
    
    case UM_Turtle:
		dx = (double)x1;
        dy = (double)x2;
    	degree = (double)y1;
        radian = PI * (degree / 180.0);
        hdc = GetDC(hwnd);
        hpen = CreatePen(PS_SOLID, 1, RGB(0,255,0));
        hbrush = CreateSolidBrush(RGB(0,255,0));
        SetROP2(hdc, R2_XORPEN);
		SelectObject(hdc, hpen);
        SelectObject(hdc,hbrush);
        for(i=0; i<3; i++){
        	po[i].x = dx + (cos(radian) * turtle[i].x) - (sin(radian) * turtle[i].y);
            po[i].y = dy - (sin(radian) * turtle[i].x) + (cos(radian) * turtle[i].y);
        }
        Polygon(hdc , po , 3);
        DeleteObject(hpen);
        DeleteObject(hbrush);
		ReleaseDC(hwnd, hdc);
		return 0;
        
    case UM_Brush:
    	brush = x1;
        return 0;
    }
	return DefWindowProc(hwnd , msg , wp , lp);
}

int WINAPI WinMain(HINSTANCE hInstance , HINSTANCE hPrevInstance ,
			PSTR lpCmdLine , int nCmdShow ) {
	HWND hwnd;
	MSG msg;
	WNDCLASS winc;

	winc.style		= CS_HREDRAW | CS_VREDRAW;
	winc.lpfnWndProc	= WndProc;
	winc.cbClsExtra	= winc.cbWndExtra	= 0;
	winc.hInstance		= hInstance;
	winc.hIcon		= LoadIcon(NULL , IDI_APPLICATION);
	winc.hCursor		= LoadCursor(NULL , IDC_ARROW);
	winc.hbrBackground	= (HBRUSH)GetStockObject(WHITE_BRUSH);
	winc.lpszMenuName	= NULL;
	winc.lpszClassName	= TEXT("easyplot");

	if (!RegisterClass(&winc)) return -1;

	hwnd = CreateWindow(
			TEXT("easyplot") , TEXT("Easy-Plot") ,
			WS_OVERLAPPEDWINDOW | WS_VISIBLE ,
			0 , 0 ,
			600 , 600 ,
			NULL , NULL , hInstance , NULL
	);


	if (hwnd == NULL) return -1;

	while(GetMessage(&msg , NULL , 0 , 0)) DispatchMessage(&msg);
	return msg.wParam;
}