366 lines
10 KiB
C
366 lines
10 KiB
C
/***********************************************************************/
|
|
/* */
|
|
/* OCaml */
|
|
/* */
|
|
/* Developed by Jacob Navia, based on code by J-M Geffroy and X Leroy */
|
|
/* */
|
|
/* Copyright 2001 Institut National de Recherche en Informatique et */
|
|
/* en Automatique. All rights reserved. This file is distributed */
|
|
/* under the terms of the GNU Library General Public License, with */
|
|
/* the special exception on linking described in file ../../LICENSE. */
|
|
/* */
|
|
/***********************************************************************/
|
|
|
|
/* $Id$ */
|
|
|
|
#include <fcntl.h>
|
|
#include <signal.h>
|
|
#include "mlvalues.h"
|
|
#include "fail.h"
|
|
#include "libgraph.h"
|
|
#include "callback.h"
|
|
#include <windows.h>
|
|
|
|
static value gr_reset(void);
|
|
static long tid;
|
|
static HANDLE threadHandle;
|
|
HWND grdisplay = NULL;
|
|
int grscreen;
|
|
COLORREF grwhite, grblack;
|
|
COLORREF grbackground;
|
|
int grCurrentColor;
|
|
struct canvas grbstore;
|
|
BOOL grdisplay_mode;
|
|
BOOL grremember_mode;
|
|
int grx, gry;
|
|
int grcolor;
|
|
extern HFONT * grfont;
|
|
MSG msg;
|
|
|
|
static char *szOcamlWindowClass = "OcamlWindowClass";
|
|
static BOOL gr_initialized = 0;
|
|
CAMLprim value caml_gr_clear_graph(void);
|
|
HANDLE hInst;
|
|
|
|
HFONT CreationFont(char *name)
|
|
{
|
|
LOGFONT CurrentFont;
|
|
memset(&CurrentFont, 0, sizeof(LOGFONT));
|
|
CurrentFont.lfCharSet = ANSI_CHARSET;
|
|
CurrentFont.lfWeight = FW_NORMAL;
|
|
CurrentFont.lfHeight = grwindow.CurrentFontSize;
|
|
CurrentFont.lfPitchAndFamily = (BYTE) (FIXED_PITCH | FF_MODERN);
|
|
strcpy(CurrentFont.lfFaceName, name); /* Courier */
|
|
return (CreateFontIndirect(&CurrentFont));
|
|
}
|
|
|
|
void SetCoordinates(HWND hwnd)
|
|
{
|
|
RECT rc;
|
|
|
|
GetClientRect(hwnd,&rc);
|
|
grwindow.width = rc.right;
|
|
grwindow.height = rc.bottom;
|
|
gr_reset();
|
|
}
|
|
|
|
void ResetForClose(HWND hwnd)
|
|
{
|
|
DeleteDC(grwindow.tempDC);
|
|
DeleteDC(grwindow.gcBitmap);
|
|
DeleteObject(grwindow.hBitmap);
|
|
memset(&grwindow,0,sizeof(grwindow));
|
|
gr_initialized = 0;
|
|
}
|
|
|
|
|
|
|
|
static LRESULT CALLBACK GraphicsWndProc(HWND hwnd,UINT msg,WPARAM wParam,LPARAM lParam)
|
|
{
|
|
PAINTSTRUCT ps;
|
|
HDC hdc;
|
|
|
|
switch (msg) {
|
|
// Create the MDI client invisible window
|
|
case WM_CREATE:
|
|
break;
|
|
case WM_PAINT:
|
|
hdc = BeginPaint(hwnd,&ps);
|
|
BitBlt(hdc,0,0,grwindow.width,grwindow.height,
|
|
grwindow.gcBitmap,0,0,SRCCOPY);
|
|
EndPaint(hwnd,&ps);
|
|
break;
|
|
// Move the child windows
|
|
case WM_SIZE:
|
|
// Position the MDI client window between the tool and status bars
|
|
if (wParam != SIZE_MINIMIZED) {
|
|
SetCoordinates(hwnd);
|
|
}
|
|
|
|
return 0;
|
|
// End application
|
|
case WM_DESTROY:
|
|
ResetForClose(hwnd);
|
|
break;
|
|
}
|
|
caml_gr_handle_event(msg, wParam, lParam);
|
|
return DefWindowProc(hwnd, msg, wParam, lParam);
|
|
}
|
|
|
|
int DoRegisterClass(void)
|
|
{
|
|
WNDCLASS wc;
|
|
|
|
memset(&wc,0,sizeof(WNDCLASS));
|
|
wc.style = CS_HREDRAW|CS_VREDRAW |CS_DBLCLKS|CS_OWNDC ;
|
|
wc.lpfnWndProc = (WNDPROC)GraphicsWndProc;
|
|
wc.hInstance = hInst;
|
|
wc.hbrBackground = (HBRUSH)(COLOR_WINDOW+1);
|
|
wc.lpszClassName = szOcamlWindowClass;
|
|
wc.lpszMenuName = 0;
|
|
wc.hCursor = LoadCursor(NULL,IDC_ARROW);
|
|
wc.hIcon = 0;
|
|
return RegisterClass(&wc);
|
|
}
|
|
|
|
static value gr_reset(void)
|
|
{
|
|
RECT rc;
|
|
int screenx,screeny;
|
|
|
|
screenx = GetSystemMetrics(SM_CXSCREEN);
|
|
screeny = GetSystemMetrics(SM_CYSCREEN);
|
|
GetClientRect(grwindow.hwnd,&rc);
|
|
grwindow.gc = GetDC(grwindow.hwnd);
|
|
grwindow.width = rc.right;
|
|
grwindow.height = rc.bottom;
|
|
if (grwindow.gcBitmap == (HDC)0) {
|
|
grwindow.hBitmap = CreateCompatibleBitmap(grwindow.gc,screenx,screeny);
|
|
grwindow.gcBitmap = CreateCompatibleDC(grwindow.gc);
|
|
grwindow.tempDC = CreateCompatibleDC(grwindow.gc);
|
|
SelectObject(grwindow.gcBitmap,grwindow.hBitmap);
|
|
SetMapMode(grwindow.gcBitmap,MM_TEXT);
|
|
MoveToEx(grwindow.gcBitmap,0,grwindow.height-1,0);
|
|
BitBlt(grwindow.gcBitmap,0,0,screenx,screeny,
|
|
grwindow.gcBitmap,0,0,WHITENESS);
|
|
grwindow.CurrentFontSize = 15;
|
|
grwindow.CurrentFont = CreationFont("Courier");
|
|
}
|
|
grwindow.CurrentColor = GetSysColor(COLOR_WINDOWTEXT);
|
|
grwindow.grx = 0;
|
|
grwindow.gry = 0;
|
|
grwindow.CurrentPen = SelectObject(grwindow.gc,GetStockObject(WHITE_PEN));
|
|
SelectObject(grwindow.gc,grwindow.CurrentPen);
|
|
SelectObject(grwindow.gcBitmap,grwindow.CurrentPen);
|
|
grwindow.CurrentBrush = SelectObject(grwindow.gc,GetStockObject(WHITE_BRUSH));
|
|
SelectObject(grwindow.gc,grwindow.CurrentBrush);
|
|
SelectObject(grwindow.gcBitmap,grwindow.CurrentBrush);
|
|
caml_gr_set_color(Val_long(0));
|
|
SelectObject(grwindow.gc,grwindow.CurrentFont);
|
|
SelectObject(grwindow.gcBitmap,grwindow.CurrentFont);
|
|
grdisplay_mode = grremember_mode = 1;
|
|
MoveToEx(grwindow.gc,0,grwindow.height-1,0);
|
|
MoveToEx(grwindow.gcBitmap,0,grwindow.height-1,0);
|
|
SetTextAlign(grwindow.gcBitmap,TA_BOTTOM);
|
|
SetTextAlign(grwindow.gc,TA_BOTTOM);
|
|
return Val_unit;
|
|
}
|
|
|
|
void SuspendGraphicThread(void)
|
|
{
|
|
SuspendThread(threadHandle);
|
|
}
|
|
|
|
void ResumeGraphicThread(void)
|
|
{
|
|
ResumeThread(threadHandle);
|
|
}
|
|
|
|
/* For handshake between the event handling thread and the main thread */
|
|
static char * open_graph_errmsg;
|
|
static HANDLE open_graph_event;
|
|
|
|
static DWORD WINAPI gr_open_graph_internal(value arg)
|
|
{
|
|
RECT rc;
|
|
int ret;
|
|
int event;
|
|
int x, y, w, h;
|
|
int screenx,screeny;
|
|
int attributes;
|
|
static int registered;
|
|
MSG msg;
|
|
|
|
gr_initialized = TRUE;
|
|
hInst = GetModuleHandle(NULL);
|
|
x = y = w = h = CW_USEDEFAULT;
|
|
sscanf(String_val(arg), "%dx%d+%d+%d", &w, &h, &x, &y);
|
|
|
|
/* Open the display */
|
|
if (grwindow.hwnd == NULL || !IsWindow(grwindow.hwnd)) {
|
|
if (!registered) {
|
|
registered = DoRegisterClass();
|
|
if (!registered) {
|
|
open_graph_errmsg = "Cannot register the window class";
|
|
SetEvent(open_graph_event);
|
|
return 1;
|
|
}
|
|
}
|
|
grwindow.hwnd = CreateWindow(szOcamlWindowClass,
|
|
WINDOW_NAME,
|
|
WS_OVERLAPPEDWINDOW,
|
|
x,y,
|
|
w,h,
|
|
NULL,0,hInst,NULL);
|
|
if (grwindow.hwnd == NULL) {
|
|
open_graph_errmsg = "Cannot create window";
|
|
SetEvent(open_graph_event);
|
|
return 1;
|
|
}
|
|
#if 0
|
|
if (x != CW_USEDEFAULT) {
|
|
rc.left = 0;
|
|
rc.top = 0;
|
|
rc.right = w;
|
|
rc.bottom = h;
|
|
AdjustWindowRect(&rc,GetWindowLong(grwindow.hwnd,GWL_STYLE),0);
|
|
MoveWindow(grwindow.hwnd,x,y,rc.right-rc.left,rc.bottom-rc.top,1);
|
|
}
|
|
#endif
|
|
}
|
|
gr_reset();
|
|
ShowWindow(grwindow.hwnd,SW_SHOWNORMAL);
|
|
|
|
/* Position the current point at origin */
|
|
grwindow.grx = 0;
|
|
grwindow.gry = 0;
|
|
|
|
caml_gr_init_event_queue();
|
|
|
|
/* The global data structures are now correctly initialized.
|
|
Restart the Caml main thread. */
|
|
open_graph_errmsg = NULL;
|
|
SetEvent(open_graph_event);
|
|
|
|
/* Enter the message handling loop */
|
|
while (GetMessage(&msg,NULL,0,0)) {
|
|
TranslateMessage(&msg); // Translates virtual key codes
|
|
DispatchMessage(&msg); // Dispatches message to window
|
|
if (!IsWindow(grwindow.hwnd))
|
|
break;
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
CAMLprim value caml_gr_open_graph(value arg)
|
|
{
|
|
long tid;
|
|
if (gr_initialized) return Val_unit;
|
|
open_graph_event = CreateEvent(NULL, FALSE, FALSE, NULL);
|
|
threadHandle =
|
|
CreateThread(NULL,0,
|
|
(LPTHREAD_START_ROUTINE)gr_open_graph_internal,(void **)arg,
|
|
0,
|
|
&tid);
|
|
WaitForSingleObject(open_graph_event, INFINITE);
|
|
CloseHandle(open_graph_event);
|
|
if (open_graph_errmsg != NULL) gr_fail("%s", open_graph_errmsg);
|
|
return Val_unit;
|
|
}
|
|
|
|
CAMLprim value caml_gr_close_graph(void)
|
|
{
|
|
if (gr_initialized) {
|
|
PostMessage(grwindow.hwnd, WM_CLOSE, 0, 0);
|
|
WaitForSingleObject(threadHandle, INFINITE);
|
|
}
|
|
return Val_unit;
|
|
}
|
|
|
|
CAMLprim value caml_gr_clear_graph(void)
|
|
{
|
|
gr_check_open();
|
|
if(grremember_mode) {
|
|
BitBlt(grwindow.gcBitmap,0,0,grwindow.width,grwindow.height,
|
|
grwindow.gcBitmap,0,0,WHITENESS);
|
|
}
|
|
if(grdisplay_mode) {
|
|
BitBlt(grwindow.gc,0,0,grwindow.width,grwindow.height,
|
|
grwindow.gc,0,0,WHITENESS);
|
|
}
|
|
return Val_unit;
|
|
}
|
|
|
|
CAMLprim value caml_gr_size_x(void)
|
|
{
|
|
gr_check_open();
|
|
return Val_int(grwindow.width);
|
|
}
|
|
|
|
CAMLprim value caml_gr_size_y(void)
|
|
{
|
|
gr_check_open();
|
|
return Val_int(grwindow.height);
|
|
}
|
|
|
|
CAMLprim value caml_gr_resize_window (value vx, value vy)
|
|
{
|
|
gr_check_open ();
|
|
|
|
/* FIXME TODO implement this function... */
|
|
|
|
return Val_unit;
|
|
}
|
|
|
|
CAMLprim value caml_gr_synchronize(void)
|
|
{
|
|
gr_check_open();
|
|
BitBlt(grwindow.gc,0,0,grwindow.width,grwindow.height,
|
|
grwindow.gcBitmap,0,0,SRCCOPY);
|
|
return Val_unit ;
|
|
}
|
|
|
|
CAMLprim value caml_gr_display_mode(value flag)
|
|
{
|
|
grdisplay_mode = (Int_val(flag)) ? 1 : 0;
|
|
return Val_unit ;
|
|
}
|
|
|
|
CAMLprim value caml_gr_remember_mode(value flag)
|
|
{
|
|
grremember_mode = (Int_val(flag)) ? 1 : 0;
|
|
return Val_unit ;
|
|
}
|
|
|
|
CAMLprim value caml_gr_sigio_signal(value unit)
|
|
{
|
|
return Val_unit;
|
|
}
|
|
|
|
CAMLprim value caml_gr_sigio_handler(void)
|
|
{
|
|
return Val_unit;
|
|
}
|
|
|
|
|
|
/* Processing of graphic errors */
|
|
|
|
static value * graphic_failure_exn = NULL;
|
|
void gr_fail(char *fmt, char *arg)
|
|
{
|
|
char buffer[1024];
|
|
|
|
if (graphic_failure_exn == NULL) {
|
|
graphic_failure_exn = caml_named_value("Graphics.Graphic_failure");
|
|
if (graphic_failure_exn == NULL)
|
|
invalid_argument("Exception Graphics.Graphic_failure not initialized, must link graphics.cma");
|
|
}
|
|
sprintf(buffer, fmt, arg);
|
|
raise_with_string(*graphic_failure_exn, buffer);
|
|
}
|
|
|
|
void gr_check_open(void)
|
|
{
|
|
if (!gr_initialized) gr_fail("graphic screen not opened", NULL);
|
|
}
|