Host/Mod/Bitmaps.odc

MODULE HostBitmaps;
(**
	project	= "BlackBox"
	organization	= "www.oberon.ch"
	contributors	= "Oberon microsystems"
	version	= "System/Rsrc/About"
	copyright	= "System/Rsrc/About"
	license	= "Docu/BB-License"
	changes	= "
	- YYYYMMDD, nn, ...
	"
	issues	= "
	- ...
	"

**)

	IMPORT
		SYSTEM, WinApi, WinOle,
		Files, Fonts, Ports, Stores, Models, Views, Controllers, Containers, Properties, Dialog, Converters,
		HostPorts, HostWindows;

	CONST
		minVersion = 0; maxVersion = 1;

	TYPE
		Model = POINTER TO RECORD
			file: Files.File;
			pos, len: INTEGER;
			ref: WinApi.HBITMAP
		END;

		StdView = POINTER TO RECORD (Views.View)
			model: Model;
			w, h: INTEGER;	(* in pixels *)
			bits: INTEGER;	(* bit per pixel *)
		END;
		
		BITMAPINFO8 = RECORD [untagged]
			header: WinApi.BITMAPINFOHEADER;
			colors: ARRAY 256 OF INTEGER
		END;
		
		RootContext = POINTER TO RECORD (Models.Context)
			w, h: INTEGER
		END;
		
		RootView = POINTER TO RECORD (Views.View)
			view: Views.View;
		END;
		
	
	(* helpers for painting to bitmap *)	
	
	PROCEDURE (c: RootContext) ThisModel (): Models.Model;
	BEGIN
		RETURN NIL
	END ThisModel;

	PROCEDURE (c: RootContext) GetSize (OUT w, h: INTEGER);
	BEGIN
		w := c.w; h := c.h
	END GetSize;
		
	PROCEDURE (c: RootContext) Normalize (): BOOLEAN;
	BEGIN
		RETURN TRUE
	END Normalize;
	
	PROCEDURE (d: RootView) Restore (f: Views.Frame; l, t, r, b: INTEGER);
	BEGIN
		Views.InstallFrame(f, d.view, 0, 0, 0, FALSE)
	END Restore;
	
	PROCEDURE (d: RootView) GetNewFrame (VAR frame: Views.Frame);
		VAR f: Views.RootFrame;
	BEGIN
		NEW(f); frame := f
	END GetNewFrame;

	PROCEDURE (d: RootView) GetBackground (VAR color: Ports.Color);
	BEGIN
		color := Ports.background
	END GetBackground;
	
	PROCEDURE Paint (dc: WinApi.HDC; v: Views.View; w, h, unit: INTEGER);
		VAR d: RootView; c: RootContext; p: HostPorts.Port; f: Views.RootFrame; g: Views.Frame;
	BEGIN
		NEW(p);
		p.Init(unit, Ports.screen);
		p.SetSize(w, h);
		p.SetDC(dc, 0);
		NEW(c);
		c.w := w * p.unit;
		c.h := h * p.unit;
		NEW(d);
		d.view := Views.CopyOf(v, Views.shallow);
		Stores.Join(d, d.view);
		d.InitContext(c);
		d.view.InitContext(c);
		Stores.InitDomain(d);
		d.GetNewFrame(g); f := g(Views.RootFrame); f.ConnectTo(p);
		Views.SetRoot(f, d, FALSE, {});
		Views.AdaptRoot(f);
		Views.RestoreRoot(f, 0, 0, c.w, c.h);
	END Paint;
	

	
	PROCEDURE GetHeader (v: StdView; OUT hdr: WinApi.BITMAPINFOHEADER; OUT colors: INTEGER);
	BEGIN
		hdr.biSize := SIZE(WinApi.BITMAPINFOHEADER);
		hdr.biWidth := v.w;
		hdr.biHeight := v.h;
		hdr.biPlanes := 1;
		hdr.biBitCount := SHORT(v.bits);
		IF v.bits = 8 THEN	(* use 8 bit & run length encoding *)
			hdr.biCompression := WinApi.BI_RLE8;
			colors := 256
		ELSIF v.bits = 24 THEN	(* use 24 bit true color *)
			hdr.biCompression := WinApi.BI_RGB;
			colors := 0
		ELSIF v.bits = 0 THEN	(* use jpeg *)
			hdr.biCompression := 4 (* WinApi.BI_JPEG *);
			colors := 0
		ELSE
			HALT(100)	(* unsupported format *)
		END;
		hdr.biSizeImage := 0;
		hdr.biXPelsPerMeter := 0;
		hdr.biYPelsPerMeter := 0;
		hdr.biClrUsed := 0;
		hdr.biClrImportant := 0
	END GetHeader;
	
	PROCEDURE Evaluate (v: StdView; dc: WinApi.HDC);
		VAR len, adr, res, colors, i: INTEGER;
			rd: Stores.Reader; info: BITMAPINFO8; data: POINTER TO ARRAY OF BYTE;
	BEGIN
		rd.ConnectTo(v.model.file);
		rd.SetPos(v.model.pos);
		len := v.model.len;
		GetHeader(v, info.header, colors);
		i := 0; WHILE i < colors DO rd.ReadInt(info.colors[i]); INC(i); DEC(len, 4) END;
		NEW(data, len);
		rd.rider.ReadBytes(data^, 0, len);
		v.model.ref := WinApi.CreateCompatibleBitmap(dc, v.w, v.h);
		info.header.biSizeImage := len;
		res := WinApi.SetDIBits(dc, v.model.ref, 0, v.h, SYSTEM.ADR(data[0]),
			SYSTEM.VAL(WinApi.BITMAPINFO, info), WinApi.DIB_RGB_COLORS);
		IF res = 0 THEN
			res := WinApi.GetLastError();
			IF res = WinApi.ERROR_NOT_ENOUGH_MEMORY THEN HALT(101) ELSE HALT(100) END
		END;
		ASSERT(v.model.ref # 0, 102)
	END Evaluate;


	(* Model *)
	
	PROCEDURE (m: Model) FINALIZE;
		VAR res: INTEGER;
	BEGIN
		IF m.ref # 0 THEN
			res := WinApi.DeleteObject(m.ref);
			m.ref := 0
		END
	END FINALIZE;
	

	(* View *)

	PROCEDURE (v: StdView) Internalize (VAR rd: Stores.Reader);
		VAR m: Model; thisVersion: INTEGER;
	BEGIN
		v.Internalize^(rd);
		IF rd.cancelled THEN RETURN END;
		rd.ReadVersion(minVersion, maxVersion, thisVersion);
		IF rd.cancelled THEN RETURN END;
		rd.ReadInt(v.w);
		rd.ReadInt(v.h);
		IF thisVersion > 0 THEN rd.ReadInt(v.bits) ELSE v.bits := 24 END;
		NEW(m); m.file := rd.rider.Base();
		rd.ReadInt(m.len);
		m.pos := rd.Pos();
		m.ref := 0;	(* lazy allocation of bitmap data *)
		v.model := m;
		rd.SetPos(m.pos + m.len)
	END Internalize;

	PROCEDURE (v: StdView) Externalize (VAR wr: Stores.Writer);
		VAR len, res, colors, i: INTEGER;
			r: Files.Reader; b: BYTE; info: BITMAPINFO8; data: POINTER TO ARRAY OF BYTE;
	BEGIN
		v.Externalize^(wr);
		wr.WriteVersion(maxVersion);
		wr.WriteInt(v.w);
		wr.WriteInt(v.h);
		wr.WriteInt(v.bits);
		IF v.model.file # NIL THEN
			len := v.model.len;
			wr.WriteInt(len);
			r := v.model.file.NewReader(NIL); r.SetPos(v.model.pos);
			WHILE len # 0 DO r.ReadByte(b); wr.WriteSChar(SHORT(CHR(b))); DEC(len) END
		ELSE
			ASSERT(v.model.ref # 0, 100);
			GetHeader(v, info.header, colors);
			res := WinApi.GetDIBits(WinApi.GetDC(HostWindows.main), v.model.ref, 0, v.h, 0,
				SYSTEM.VAL(WinApi.BITMAPINFO, info), WinApi.DIB_RGB_COLORS);
			IF res = 0 THEN res := WinApi.GetLastError(); HALT(100) END;
			len := info.header.biSizeImage;
			NEW(data, len);
			res := WinApi.GetDIBits(WinApi.GetDC(HostWindows.main), v.model.ref, 0, v.h,
				SYSTEM.ADR(data[0]),
				SYSTEM.VAL(WinApi.BITMAPINFO, info), WinApi.DIB_RGB_COLORS);
			IF res = 0 THEN res := WinApi.GetLastError(); HALT(100) END;
			INC(len, 4 * colors);
			wr.WriteInt(len);
			i := 0; WHILE i < colors DO wr.WriteInt(info.colors[i]); INC(i) END;
			wr.rider.WriteBytes(data^, 0, LEN(data));
			v.model.len := len
		END;
	END Externalize;

	PROCEDURE (v: StdView) CopyFromSimpleView (source: Views.View);
	BEGIN
		WITH source: StdView DO
			v.model := source.model;
			v.w := source.w;
			v.h := source.h;
			v.bits := source.bits;
		END
	END CopyFromSimpleView;

	PROCEDURE (v: StdView) Restore (f: Views.Frame; l, t, r, b: INTEGER);
		VAR rd: HostPorts.Rider; res, w, h: INTEGER; dc, pdc, bdc, bdc1: WinApi.HDC; memBM: WinApi.HBITMAP;
	BEGIN
		ASSERT(v.model # NIL, 20);
		v.context.GetSize(w, h);
		dc := f.rider(HostPorts.Rider).port.homedc;
		IF WinApi.WindowFromDC(dc) = 0 THEN dc := WinApi.GetDC(HostWindows.main) END;
		IF v.model.ref = 0 THEN Evaluate(v, dc) END;
		IF Views.IsPrinterFrame(f) THEN (* need to make a print copy of the existing bitmap *)
			bdc1 := WinApi.CreateCompatibleDC(dc);
			res := WinApi.SelectObject(bdc1, v.model.ref);
			pdc := f.rider(HostPorts.Rider).port.dc;
			bdc := WinApi.CreateCompatibleDC(pdc);
			memBM := WinApi.CreateCompatibleBitmap(pdc, v.w, v.h);
			res := WinApi.SelectObject(bdc, memBM);
			res := WinApi.BitBlt(bdc, 0, 0, v.w, v.h, bdc1, 0, 0, 00CC0020H);	(* copy *)
			res := WinApi.DeleteDC(bdc1)
		ELSE
			bdc := WinApi.CreateCompatibleDC(dc);
			res := WinApi.SelectObject(bdc, v.model.ref)
		END;
		f.rider(HostPorts.Rider).DrawBitmap(bdc, v.w, v.h, f.gx, f.gy, w, h);
		res := WinApi.DeleteDC(bdc)
	END Restore;

	PROCEDURE (v: StdView) HandlePropMsg (VAR msg: Properties.Message);
	BEGIN
		WITH msg: Properties.SizePref DO
			IF (msg.w > Views.undefined) & (msg.h > Views.undefined) THEN
				Properties.ProportionalConstraint(v.w, v.h, msg.fixedW, msg.fixedH, msg.w, msg.h)
			ELSE
				IF (v.w > 0) & (v.h > 0) THEN	(* default sizes *)
					msg.w := v.w * HostWindows.unit; msg.h := v.h * HostWindows.unit
				END
			END
		ELSE
		END
	END HandlePropMsg;
	

	PROCEDURE TurnToBitmap* (bits: INTEGER);
		VAR v: Views.View; f: Views.Frame; rd: HostPorts.Rider; dc, bdc: WinApi.HDC; bm: WinApi.HBITMAP;
			res, w, h: INTEGER; obj: StdView;
	BEGIN
		ASSERT((bits = 0) OR (bits = 8) OR (bits = 24), 20);
		v := Containers.FocusSingleton();
		IF v # NIL THEN
			f := Controllers.FocusFrame();
			f := Views.ThisFrame(f, v);
			rd := f.rider(HostPorts.Rider);
			dc := rd.port.homedc;
			bdc := WinApi.CreateCompatibleDC(dc);
			res := WinApi.SetBkMode(bdc, WinApi.TRANSPARENT);
			v.context.GetSize(w, h);
			w := w DIV f.unit; h := h DIV f.unit;
			bm := WinApi.CreateCompatibleBitmap(dc, w, h);
			res := WinApi.SelectObject(bdc, bm);
			Paint(bdc, v, w, h, f.unit);
			res := WinApi.DeleteDC(bdc);
			NEW(obj); obj.w := w; obj.h := h; obj.bits := bits;
			NEW(obj.model); obj.model.ref := bm;
			Containers.Focus().ThisView().ThisModel().ReplaceView(v, obj)
		END
	END TurnToBitmap;
(*
	PROCEDURE TurnThisToBitmap* (v: Views.View; owner: Containers.Model; bits: INTEGER);
		VAR dc, bdc: WinApi.HDC; bm: WinApi.HBITMAP; res, w, h: INTEGER; obj: StdView;
	BEGIN
		dc := WinApi.GetDC(HostWindows.main);
		bdc := WinApi.CreateCompatibleDC(dc);
		res := WinApi.SetBkMode(bdc, WinApi.TRANSPARENT);
		v.context.GetSize(w, h);
		w := w DIV HostWindows.unit; h := h DIV HostWindows.unit;
		bm := WinApi.CreateCompatibleBitmap(dc, w, h);
		res := WinApi.SelectObject(bdc, bm);
		Paint(bdc, v, w, h, HostWindows.unit);
		res := WinApi.DeleteDC(bdc);
		NEW(obj); obj.w := w; obj.h := h; obj.bits := bits;
		NEW(obj.model); obj.model.ref := bm;
		owner.ReplaceView(v, obj)
	END TurnThisToBitmap;
*)
	PROCEDURE ViewToBitmap* (v: Views.View; bits: INTEGER): Views.View;
		VAR dc, bdc: WinApi.HDC; bm: WinApi.HBITMAP; res, w, h: INTEGER; obj: StdView;
	BEGIN
		ASSERT(v # NIL, 20);
		IF v IS StdView THEN
			RETURN v
		ELSE
			ASSERT((bits = 0) OR (bits = 8) OR (bits = 24), 21);
			dc := WinApi.GetDC(HostWindows.main);
			bdc := WinApi.CreateCompatibleDC(dc);
			res := WinApi.SetBkMode(bdc, WinApi.TRANSPARENT);
			v.context.GetSize(w, h);
			w := w DIV HostWindows.unit; h := h DIV HostWindows.unit;
			bm := WinApi.CreateCompatibleBitmap(dc, w, h);
			res := WinApi.SelectObject(bdc, bm);
			Paint(bdc, v, w, h, HostWindows.unit);
			res := WinApi.DeleteDC(bdc);
			NEW(obj); obj.w := w; obj.h := h; obj.bits := bits;
			NEW(obj.model); obj.model.ref := bm;
			RETURN obj
		END
	END ViewToBitmap;


	PROCEDURE ImportBitmap* (f: Files.File; OUT s: Stores.Store);
		TYPE Str = POINTER TO ARRAY [untagged] OF CHAR;
		VAR name: Str; bm: WinApi.HBITMAP; obj: StdView; res: INTEGER;
			sname: ARRAY 260 OF SHORTCHAR; info: WinApi.BITMAP;
	BEGIN
		name := SYSTEM.VAL(Str, SYSTEM.VAL(INTEGER, f) + 40);	(* f(HostFiles.File).name *)
		sname := SHORT(name$);
		bm := WinApi.LoadImage(0, sname, WinApi.IMAGE_BITMAP, 0, 0, ORD(WinApi.LR_LOADFROMFILE));
		IF bm = 0 THEN res := WinApi.GetLastError(); HALT(100) END;
		res := WinApi.GetObject(bm, SIZE(WinApi.BITMAP), SYSTEM.ADR(info));
		NEW(obj); obj.w := info.bmWidth; obj.h := info.bmHeight;
		IF info.bmBitsPixel > 8 THEN obj.bits := 24 ELSE obj.bits := 8 END;
		NEW(obj.model); obj.model.ref := bm;
		s := obj
	END ImportBitmap;

	PROCEDURE ExportBitmap* (v: Stores.Store; f: Files.File);
		VAR w: Stores.Writer; info: BITMAPINFO8; i, col, res: INTEGER; data: POINTER TO ARRAY OF BYTE;
	BEGIN
		ASSERT(v # NIL, 20); ASSERT(f # NIL, 21);
		WITH v: StdView DO
			GetHeader(v, info.header, col);
			res := WinApi.GetDIBits(WinApi.GetDC(HostWindows.main), v.model.ref, 0, v.h, 0,
				SYSTEM.VAL(WinApi.BITMAPINFO, info), WinApi.DIB_RGB_COLORS);
			IF res = 0 THEN res := WinApi.GetLastError(); HALT(100) END;
			NEW(data, info.header.biSizeImage);
			res := WinApi.GetDIBits(WinApi.GetDC(HostWindows.main), v.model.ref, 0, v.h,
				SYSTEM.ADR(data[0]),
				SYSTEM.VAL(WinApi.BITMAPINFO, info), WinApi.DIB_RGB_COLORS);
			IF res = 0 THEN res := WinApi.GetLastError(); HALT(100) END;
			w.ConnectTo(f);
			w.SetPos(0);
			(* file header *)
			w.WriteSInt(4D42H);	(* type *)
			w.WriteInt(14 + 40 + 4 * col + LEN(data));	(* size *)
			w.WriteInt(0);
			w.WriteInt(14 + 40 + 4 * col);	(* offset *)
			(* bitmap header *)
			w.WriteInt(info.header.biSize);
			w.WriteInt(info.header.biWidth);
			w.WriteInt(info.header.biHeight);
			w.WriteSInt(info.header.biPlanes);
			w.WriteSInt(info.header.biBitCount);
			w.WriteInt(info.header.biCompression);
			w.WriteInt(info.header.biSizeImage);
			w.WriteInt(info.header.biXPelsPerMeter);
			w.WriteInt(info.header.biYPelsPerMeter);
			w.WriteInt(info.header.biClrUsed);
			w.WriteInt(info.header.biClrImportant);
			(* colors *)
			i := 0; WHILE i < col DO w.WriteInt(info.colors[i]); INC(i) END;
			(* bits *)
			w.rider.WriteBytes(data^, 0, LEN(data))
		ELSE
		END
	END ExportBitmap;


	PROCEDURE ImportDPictAsBitmap* (VAR med: WinOle.STGMEDIUM;
		OUT v: Views.View; OUT w, h: INTEGER; OUT isSingle: BOOLEAN
	);
		VAR hm: WinApi.HMETAFILEPICT; mp: WinApi.PtrMETAFILEPICT;
			dc, bdc: WinApi.HDC; res, u: INTEGER; bm: WinApi.HBITMAP; obj: StdView; s: SET;
	BEGIN
		hm := med.u.hMetaFilePict;
		mp := SYSTEM.VAL(WinApi.PtrMETAFILEPICT, WinApi.GlobalLock(hm));
		CASE mp.mm OF
		| 1: u := HostWindows.unit
		| 2: u := Ports.point DIV 20
		| 3: u := Ports.mm DIV 100
		| 4: u := Ports.inch DIV 100
		| 5: u := Ports.inch DIV 1000
		| 6: u := Ports.mm DIV 10
		| 7: u := Ports.mm DIV 100
		| 8: u := Ports.mm DIV 100
		END;
		w := mp.xExt * u; h := mp.yExt * u;
		NEW(obj); obj.bits := 24;
		obj.w := w DIV HostWindows.unit;
		obj.h := h DIV HostWindows.unit;
		dc := WinApi.GetDC(HostWindows.main);
		bdc := WinApi.CreateCompatibleDC(dc);
		res := WinApi.SetBkMode(bdc, WinApi.TRANSPARENT);
		bm := WinApi.CreateCompatibleBitmap(dc, obj.w, obj.h);
		res := WinApi.SelectObject(bdc, bm);
		res := WinApi.SetMapMode(bdc, mp.mm);
		res := WinApi.SetViewportOrgEx(bdc, 0, 0, NIL);
		res := WinApi.SetViewportExtEx(bdc, obj.w, obj.h, NIL);
		s := WinApi.SetTextAlign(bdc, {});
		res := WinApi.PlayMetaFile(bdc, mp.hMF);
		res := WinApi.GlobalUnlock(hm);
		res := WinApi.DeleteDC(bdc);
		WinOle.ReleaseStgMedium(med);
		NEW(obj.model); obj.model.ref := bm;
		v := obj; isSingle := FALSE
	END ImportDPictAsBitmap;

	PROCEDURE ImportDBitmap* (VAR med: WinOle.STGMEDIUM;
		OUT v: Views.View; OUT w, h: INTEGER; OUT isSingle: BOOLEAN
	);
		VAR obj: StdView; res: INTEGER;
			bm, bm0: WinApi.HBITMAP; info: WinApi.BITMAP; dc, bdc, bdc0: WinApi.HDC;
	BEGIN
		ASSERT(med.tymed = WinOle.TYMED_GDI, 20);
		bm0 := med.u.hBitmap;
		ASSERT(bm0 # 0, 20);
		res := WinApi.GetObject(bm0, SIZE(WinApi.BITMAP), SYSTEM.ADR(info));
		NEW(obj);
		obj.w := info.bmWidth;
		obj.h := info.bmHeight;
		IF info.bmBitsPixel > 8 THEN obj.bits := 24 ELSE obj.bits := 8 END;
		dc := WinApi.GetDC(HostWindows.main);
		bdc0 := WinApi.CreateCompatibleDC(dc);
		res := WinApi.SelectObject(bdc0, bm0);
		bdc := WinApi.CreateCompatibleDC(dc);
		bm := WinApi.CreateCompatibleBitmap(dc, obj.w, obj.h);
		res := WinApi.SelectObject(bdc, bm);
		res := WinApi.BitBlt(bdc, 0, 0, obj.w, obj.h, bdc0, 0, 0, 00CC0020H);	(* copy *)
		IF res = 0 THEN res := WinApi.GetLastError(); HALT(100) END;
		res := WinApi.DeleteDC(bdc0);
		res := WinApi.DeleteDC(bdc);
		WinOle.ReleaseStgMedium(med);
		NEW(obj.model); obj.model.ref := bm;
		v := obj; w := obj.w * HostWindows.unit; h := obj.h * HostWindows.unit; isSingle := FALSE
	END ImportDBitmap;

	PROCEDURE ExportDBitmap* (v: Views.View; w, h, x, y: INTEGER; isSingle: BOOLEAN;
		VAR med: WinOle.STGMEDIUM
	);
	BEGIN
		ASSERT(v # NIL, 20);
		WITH v: StdView DO
			IF v.model.ref = 0 THEN Evaluate(v, WinApi.GetDC(HostWindows.main)) END;
			med.tymed := WinOle.TYMED_GDI;
			med.u.hBitmap := v.model.ref;
			med.pUnkForRelease := NIL
		ELSE
		END
	END ExportDBitmap;

END HostBitmaps.