LoginSignup
0
0

More than 5 years have passed since last update.

@sym_num(笹川 賢一)infukuoka.ex：福岡Elixirコミュ

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

Last updated at Posted at 2017-06-10

はじめに

コンパイラの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;
}
0
0
0

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
Sign upLogin
0
0