implement Mand; ## Copyright © 2000 Vita Nuova Limited. All rights reserved.# # mandelbrot/julia fractal browser:# button 1 - drag a rectangle to zoom into# button 2 - (from mandel only) show julia at point# button 3 - zoom out include "sys.m";	sys : Sys;include "draw.m";	draw : Draw;	Point, Rect, Image, Context, Screen, Display : import draw;include "tk.m";	tk: Tk;include "tkclient.m";	tkclient: Tkclient; Mand : module{	init : fn(nil : ref Context, argv : list of string);}; colours: array of ref Image;stderr : ref Sys->FD; FIX: type big; Calc: adt {	xr, yr: array of FIX;	parx, pary: FIX;	# column order	dispbase: array of COL;		# auxiliary display and border	imgch: chan of (ref Image, Rect);	img: ref Image;	maxx, maxy, supx, supy: int;	disp: int;					# origin of auxiliary display	morj : int;	winr: Rect;	kdivisor: int;	pointsdone: int;}; # BASE, LIMIT, MAXCOUNT, MINDELTA may be varied ##	calls with 256X128 on initial set#	---------------------------------#	crawl		58	(5% of time)#	fillline	894	(6% of time)#	isblank		5012	(0% of time)#	mcount		6928	(55% of time)#	getcolour	52942	(11% of time)#	displayset	1	(15% of time)#WHITE : con 16r0;BLACK : con 16rff; COL : type byte; BASE	: con 60;		# 28HBASE : con (BASE/2);SCALE : con (big 1<<BASE);TWO	: con (big 1<<(BASE+1));FOUR : con (big 1<<(BASE+2));NEG	: con (~((big 1<<(32-HBASE))-big 1));MINDELTA : con (big 1<<(HBASE-1));		# (1<<(HBASE-2)) SCHEDCOUNT: con 100; BLANK : con 0;		# blank pixelBORDER : con 255;	# border pixelLIMIT : con 4;		# 4 or 5 # pointcolour() returns values in the range 1..MAXCOUNT+1# these must not clash with 0 or 255# hence 0 <= MAXCOUNT <= 253#MAXCOUNT : con 253;		# 92  64 # colour cubeR, G, B : int; # initial width and heightWIDTH: con 400;HEIGHT: con 400; Fracpoint: adt {	x, y: real;}; Fracrect: adt {	min, max: Fracpoint;}; Params: adt {	r: Fracrect;	p: Fracpoint;	m: int;	kdivisor: int;	fill: int;}; Usercmd: adt {	pick {	Zoomin =>		r: Rect;	Julia =>		p: Point;	Zoomout or	Restart =>		# nothing	}}; badmod(mod: string){	sys->fprint(stderr, "mand: cannot load %s: %r\n", mod);	raise "fail:bad module";} win_config := array[] of {	"frame .f",	"label .f.dl -text Depth",	"entry .f.depth",	".f.depth insert 0 1",	"checkbutton .f.fill -text {Fill} -command {send cmd fillchanged} -variable fill",	".f.fill select",	"pack .f.dl -side left",	"pack .f.fill -side right",	"pack .f.depth -side top -fill x",	"frame .c -bd 3 -relief sunken -width " + string WIDTH + " -height " + string HEIGHT,	"pack .f -side top -fill x",	"pack .c -side bottom -fill both -expand 1",	"pack propagate . 0",	"bind .c <Button-1> {send cmd b1 %x %y}",	"bind .c <ButtonRelease-2> {send cmd b2 %x %y}",	"bind .c <ButtonRelease-1> {send cmd b1r %x %y}",	"bind .c <ButtonRelease-3> {send cmd b3 %x %y}", 	"bind .f.depth <Key-\n> {send cmd setkdivisor}",	"update",}; mouseproc(win: ref Tk->Toplevel){	for(;;)		tk->pointer(win, *<-win.ctxt.ptr);} init(ctxt: ref Context, argv : list of string){	sys = load Sys Sys->PATH;	stderr = sys->fildes(2); 	draw = load Draw Draw->PATH;	tk = load Tk Tk->PATH; 	tkclient = load Tkclient Tkclient->PATH;	if (tkclient == nil) badmod(Tkclient->PATH); 	tkclient->init();	if (ctxt == nil)		ctxt = tkclient->makedrawcontext();	(win, wmcmd) := tkclient->toplevel(ctxt, "", "Fractals", Tkclient->Appl);	sys->pctl(Sys->NEWPGRP, nil); 	cmdch := chan of string;	tk->namechan(win, cmdch, "cmd");	for (i := 0; i < len win_config; i++)		cmd(win, win_config[i]);	tkclient->onscreen(win, nil);	tkclient->startinput(win, "kbd"::"ptr"::nil);	fittoscreen(win);	cmd(win, "update");	spawn mouseproc(win); 	R = G = B = 6;	argv = tl argv;	if (argv != nil) { (R, argv) = (int hd argv, tl argv); if (R <= 0) R = 1; }	if (argv != nil) { (G, argv) = (int hd argv, tl argv); if (G <= 0) G = 1; }	if (argv != nil) { (B, argv) = (int hd argv, tl argv); if (B <= 0) B = 1; }	colours = array[256] of ref Image;	for (i = 0; i < len colours; i++)		# colours[i] = ctxt.display.color(i);		colours[i] = ctxt.display.rgb(col(i/(G*B), R),							    col(i/(1*B), G),							    col(i/(1*1), B));	specr := Fracrect((-2.0, -1.5), (1.0, 1.5));	p := Params(			correctratio(specr, win),			(0.0, 0.0),			1,			# m			1,			# kdivisor			int cmd(win, "variable fill")		);	pid := -1;	sync := chan of int;	imgch := chan of (ref Image, Rect);	canvr := canvposn(win);	spawn docalculate(sync, p, imgch);	pid = <-sync;	imgch <-= (win.image, canvr); 	stack: list of (Fracrect, Params);	for(;;){		restart := 0;		alt {		s := <-win.ctxt.kbd =>			tk->keyboard(win, s);		c := <-win.ctxt.ctl or		c = <-win.wreq or		c = <-wmcmd =>			if(c[0] == '!'){				if(pid != -1)					restart = winreq(win, c, imgch, sync);				else					restart = winreq(win, c, nil, nil);			}else{				tkclient->wmctl(win, c);				if(c == "task" && pid != -1){					kill(pid);					pid = -1;				}			}		press := <-cmdch =>			(nil, toks) := sys->tokenize(press, " ");			ucmd: ref Usercmd = nil;			case hd toks {			"start" =>				ucmd = ref Usercmd.Restart;			"b1" or "b2" or "b3" =>				#cmd(win, "grab set .c");				#fiximage(win);				ucmd = trackmouse(win, cmdch, hd toks, Point(int hd tl toks, int hd tl tl toks));				#cmd(win, "grab release .c");			"fillchanged" =>				p.fill = int cmd(win, "variable fill");				ucmd = ref Usercmd.Restart;			"setkdivisor" =>				p.kdivisor = int cmd(win, ".f.depth get");				if (p.kdivisor < 1)					p.kdivisor = 1;				ucmd = ref Usercmd.Restart;			}			if (ucmd != nil) {				pick u := ucmd {				Zoomin =>					# sys->print("zoomin to %s\n", r2s(u.r));					if (u.r.dx() > 0 && u.r.dy() > 0) {						stack = (specr, p) :: stack;						specr.min = pt2real(u.r.min, win, p.r);						specr.max = pt2real(u.r.max, win, p.r);						(specr.min.y, specr.max.y) = (specr.max.y, specr.min.y);	# canonicalise						restart = 1;					}				Zoomout =>					if (stack != nil) {						((specr, p), stack) = (hd stack, tl stack);						cmd(win, ".f.depth delete 0 end");						cmd(win, ".f.depth insert 0 " + string p.kdivisor);						if (p.fill)							cmd(win, ".f.fill select");						else							cmd(win, ".f.fill deselect");						cmd(win, "update");						restart = 1;					}				Julia =>					# pt := pt2real(u.p, win, p.r);					if (p.m) {						stack = (specr, p) :: stack;						p.p = pt2real(u.p, win, p.r);						specr = ((-2.0, -1.5), (1.0, 1.5));						p.m = 0;						restart = 1;					}				Restart =>					restart = 1;				}			}		<-sync =>			win.image.flush(Draw->Flushon);			pid = -1;		}		if (restart) {			if (pid != -1)				kill(pid);			win.image.flush(Draw->Flushoff);			p.r = correctratio(specr, win);			sync = chan of int;			spawn docalculate(sync, p, imgch);			pid = <-sync;			imgch <-= (win.image, canvposn(win));		}	}} winreq(win: ref Tk->Toplevel, c: string, imgch: chan of (ref Image, Rect), terminated: chan of int): int{	oldimage := win.image;	if (imgch != nil) {		# halt calculation process		alt {		imgch <-= (nil, ((0,0), (0,0))) =>;		<-terminated =>			imgch = nil;		}	}	tkclient->wmctl(win, c);	if(win.image != oldimage)		return 1;	if(imgch != nil)		imgch <-= (win.image, canvposn(win));	return 0;} correctratio(r: Fracrect, win: ref Tk->Toplevel): Fracrect{	# make sure calculation rectangle is in	# the same ratio as bitmap (also make sure that	# calculated area always includes desired area)	wr := canvposn(win);	(btall, atall) := (real wr.dy() / real wr.dx(), (r.max.y - r.min.y) / (r.max.x - r.min.x));	if (btall > atall) {		# bitmap is taller than area, so expand area vertically		excess := (r.max.x - r.min.x) * btall - (r.max.y - r.min.y);		r.min.y -= excess / 2.0;		r.max.y += excess / 2.0;	} else {		# area is taller than bitmap, so expand area horizontally		excess := (r.max.y - r.min.y) / btall - (r.max.x - r.min.x);		r.min.x -= excess / 2.0;		r.max.x += excess / 2.0;	}	return r;} pt2real(pt: Point, win: ref Tk->Toplevel, r: Fracrect): Fracpoint{	sz := Point(int cmd(win, ".c cget -actwidth"), int cmd(win, ".c cget -actheight"));	return (real pt.x / real sz.x * (r.max.x- r.min.x) + r.min.x,			real (sz.y - pt.y) / real sz.y * (r.max.y - r.min.y) + r.min.y);} pt2s(pt: Point): string{	return string pt.x + " " + string pt.y;} r2s(r: Rect): string{	return pt2s(r.min) + " " + pt2s(r.max);} trackmouse(win: ref Tk->Toplevel, cmdch: chan of string, but: string, p: Point): ref Usercmd{	case but {	"b1" =>		cr := canvposn(win);		display := win.image.display;		save := display.newimage(cr, win.image.chans, 0, Draw->Nofill);		save.draw(cr, win.image, nil, cr.min);		oclip := win.image.clipr;		win.image.clipr = cr; 		p = p.add(cr.min);		r := Rect(p, p);		win.image.border(r, 1, display.white, (0, 0));		win.image.flush(Draw->Flushnow);		do {			but = <-cmdch;			(nil, toks) := sys->tokenize(but, " ");			but = hd toks;			if(but == "b1"){				xr := r.canon();				win.image.draw(xr, save, nil, xr.min);				(r.max.x, r.max.y) = (int hd tl toks + cr.min.x, int hd tl tl toks + cr.min.y);				win.image.border(r.canon(), 1, display.white, (0, 0));				win.image.flush(Draw->Flushnow);			}		} while (but != "b1r");		r = r.canon();		win.image.draw(r, save, nil, r.min);		win.image.clipr = oclip;		r = r.subpt(cr.min);		return ref Usercmd.Zoomin(r);	"b2" =>		return ref Usercmd.Julia(p);	"b3" =>		return ref Usercmd.Zoomout;	}	return nil;} poll(calc: ref Calc){	calc.img.flush(Draw->Flushnow);	alt {	<-calc.imgch =>		calc.img = nil;		(calc.img, calc.winr) = <-calc.imgch;	* =>;	}} docalculate(sync: chan of int, p: Params, imgch: chan of (ref Image, Rect)){	if (p.m)		; # sys->print("mandel [[%g,%g],[%g,%g]]\n", r.min.x, r.min.y, r.max.x, r.max.y);	else		; # sys->print("julia  [[%g,%g],[%g,%g]] [%g,%g]\n", r.min.x, r.min.y, r.max.x, r.max.y, p.p.x, p.p.y);	sync <-= sys->pctl(0, nil);	calculate(p, imgch);	sync <-= 0;} canvposn(win: ref Tk->Toplevel): Rect{	return tk->rect(win, ".c", Tk->Local);} calculate(p: Params, imgch: chan of (ref Image, Rect)){	calc := ref Calc;	(calc.img, calc.winr) = <-imgch;	r := calc.winr;	calc.maxx = r.dx();	calc.maxy = r.dy();	calc.supx = calc.maxx + 2;	calc.supy = calc.maxy + 2;	calc.imgch = imgch;	calc.xr = array[calc.maxx] of FIX;	calc.yr = array[calc.maxy] of FIX;	calc.morj = p.m;	initr(calc, p);	calc.img.drawop(r, calc.img.display.white, nil, (0,0), Draw->S); 	if (p.fill) {		calc.dispbase = array[calc.supx*calc.supy] of COL;		# auxiliary display and border		calc.disp = calc.maxy + 3;		setdisp(calc);		displayset(calc);	} else {		for (x := 0; x < calc.maxx; x++) {			for (y := 0; y < calc.maxy; y++)				point(calc, calc.img, (x, y), pointcolour(calc, x, y));		}	}} setdisp(calc: ref Calc){	d : int;	i : int; 	for (i = 0; i < calc.supx*calc.supy; i++)		calc.dispbase[i] = byte BLANK; 	i = 0;	for (d = 0; i < calc.supx; d += calc.supy) {		calc.dispbase[d] = byte BORDER;		i++;	}	i = 0;	for (d = 0; i < calc.supy; d++) {		calc.dispbase[d] = byte BORDER;		i++;	}	i = 0;	for (d = 0+calc.supx*calc.supy-1; i < calc.supx; d -= calc.supy) {		calc.dispbase[d] = byte BORDER;		i++;	}	i = 0;	for (d = 0+calc.supx*calc.supy-1; i < calc.supy; d--) {		calc.dispbase[d] = byte BORDER;		i++;	}} initr(calc: ref Calc, p: Params): int{	r := p.r;	dp := real2fix((r.max.x-r.min.x)/(real calc.maxx));	dq := real2fix((r.max.y-r.min.y)/(real calc.maxy));	calc.xr[0] = real2fix(r.min.x)-(big calc.maxx*dp-(real2fix(r.max.x)-real2fix(r.min.x)))/big 2;	for (x := 1; x < calc.maxx; x++)		calc.xr[x] = calc.xr[x-1] + dp;	calc.yr[0] = real2fix(r.max.y)+(big calc.maxy*dq-(real2fix(r.max.y)-real2fix(r.min.y)))/big 2;	for (y := 1; y < calc.maxy; y++)		calc.yr[y] = calc.yr[y-1] - dq;	calc.parx = real2fix(p.p.x);	calc.pary = real2fix(p.p.y);	calc.kdivisor = p.kdivisor;	calc.pointsdone = 0;	return dp >= MINDELTA && dq >= MINDELTA;

Lines 1–500 of 839. Load more