It uses derivatives for the coloring of the boundary points, that makes it slow, but results are interesting.
Use mouse to select a new region.
Code:
'Mini mandelbrot viewer by Antoni Gual 4/2006
'bounding box routine bt DJ.Peters
'HsvToRgb and coloring scheme by Jark
'--------------------------------------------------------------------------
option explicit
#define maxx 800
#define maxy 600
#define hmaxx (maxx/2)
#define hmaxy (maxy/2)
#define frel (maxx/maxy)
enum rendermeths
rndr_dazibao=0
rndr_bw
rndr_md
rndr_solar
end enum
type mdbrestype
nit as double
maxmod as double
strip as double
dea as double
par as integer
end type
dim shared as double zoomfact
type myrect
as integer x0,y0,x1,y1
end type
'
'-------------------------------------------------------------------------------
sub DrawXorBox(byval x0 as integer,byval y0 as integer ,_
byval x1 as integer,byval y1 as integer)
dim as integer x,y,c
if x0>x1 then swap x0,x1
if y0>y1 then swap y0,y1
for x=x0 to x1:c=point(x,y0):c=c xor &hffffff:pset(x,y0),c:next
if y0<>y1 then for x=x0 to x1:c=point(x,y1):c=c xor &hffffff :pset(x,y1),c:next
for y=y0 to y1:c=point(x0,y):c=c xor &hffffff:pset(x0,y),c:next
if x0<>x1 then for y=y0 to y1:c=point(x1,y):c=c xor &hffffff:pset(x1,y),c:next
end sub
'
'-------------------------------------------------------------------------------
function boundbox (byval x as integer,byval y as integer) as myrect
dim as integer newx,newy,oldx,oldy,button,sx,sy
dim as myrect r
screeninfo sx,sy
oldx=x+1:oldy=y+1:button=1
DrawXorBox x,y,oldx,oldy
while button=1
sleep 0
getmouse newx,newy,,button
if newx<0 or newy<0 or newx>(sx-1) then
button=1:newx=oldx:newy=oldy
setmouse newx,newy
end if
if newx<>oldx or newy<>oldy then
r.x0=x:r.y0=y:r.x1=newx:r.y1=newy
ScreenLock
DrawXorBox x,y,oldx,oldy
DrawXorBox x,y,newx,newy
ScreenUnlock
oldx=newx:oldy=newy
end if
wend
DrawXorBox x,y,oldx,oldy
if r.x1<r.x0 then swap r.x1, r.x0
if r.y1<r.y0 then swap r.y1, r.y0
return r
end function
'
'-----------------------------------------------------------------------------------------
Function HSVtoRGB (byval Hue as single ,byval Sat as single,byval Value as single) as integer
' Converts a HSV colour definition into RGB values via exact trigonometry calculations.
' by Jark
CONST SQR12 = SQR(1/2)
CONST SQR16 = SQR(1/6)
CONST SQR23 = SQR(2/3)
CONST SatCoeff = 100/ATN(SQR(6))
CONST SatCoef = 1/SatCoeff
const pi=3.1415926#
CONST PiOver180 = pi/180
CONST PiOver2 = pi/2
dim red ,green ,blue
dim as single ur,vr,wr ,radius,angle,rdim
Angle = (Hue! - 150) * PiOver180
Ur = Value! * 2.55
Radius = Ur * TAN(Sat! * SatCoef)
Vr = Radius * COS(Angle) * SQR12
Wr = Radius * SIN(Angle) * SQR16
Red = Ur - Vr - Wr
Green = Ur + Vr - Wr
Blue = Ur + Wr + Wr
IF Red < 0 THEN
Rdim = Ur / (Vr + Wr)
Red = 0
Green = Ur + (Vr - Wr) * Rdim
Blue = Ur + 2 * Wr * Rdim
GOTO Ctrl2
END IF
IF Green < 0 THEN
Rdim = -Ur / (Vr - Wr)
Red = Ur - (Vr + Wr) * Rdim
Green = 0
Blue = Ur + 2 * Wr * Rdim
GOTO Ctrl2
END IF
IF Blue < 0 THEN
Rdim = -Ur / (Wr + Wr)
Red = Ur - (Vr + Wr) * Rdim
Green = Ur + (Vr - Wr) * Rdim
Blue = 0
GOTO Ctrl2
END IF
Ctrl2:
IF Red > 255 THEN
Rdim = (Ur - 255) / (Vr + Wr)
Red = 255
Green = Ur + (Vr - Wr) * Rdim
Blue = Ur + 2 * Wr * Rdim
END IF
IF Green > 255 THEN
Rdim = (255 - Ur) / (Vr - Wr)
Red = Ur - (Vr + Wr) * Rdim
Green = 255
Blue = Ur + 2 * Wr * Rdim
END IF
IF Blue > 255 THEN
Rdim = (255 - Ur) / (Wr + Wr)
Red = Ur - (Vr + Wr) * Rdim
Green = Ur + (Vr - Wr) * Rdim
Blue = 255
END IF
function= RGB(Red%,Green%,Blue%)
end function
'
'
'-------------------------------------------------------------------------------------
function calcmdb(byval xi as double,byval yi as double,byval maxit as integer,dea) as mdbrestype
dim as double maxmdb=0
dim n=0
dim r as mdbrestype
dim as double xn=0,yn=0,mdbmod2,t,dx,dy,x,y,x2,y2,dxn,dyn
do
x = xn
y = yn
xn = x2 - y2 + xi
yn = 2 * x * y + yi
x2 = xn * xn
y2 = yn * yn
mdbmod2 = (x2 + y2 )
if dea then
dxn = 1 + 2 * (x * dx - y * dy)
dyn = 2 * (x * dy + y * dx)
dx = dxn: dy = dyn
end if
if mdbmod2 >maxmdb then maxmdb =mdbmod2
IF mdbmod2 >= 4 THEN EXIT DO
n+=1
loop until (n=maxit)
r.par=n and 1
r.nit=n/maxit
r.maxmod=maxmdb
if n>=maxit then
x = xn*xn - yn*yn + xi
y = 2 * xn * yn + yi
r.strip =sqr((xn - x)*(xn-x) +(yn - y)*(yn-y))
end if
'this calc takes a 10% of the total rendering
if dea then r.dea=LOG(MdbMod2)*SQR(MdbMod2 / (dx^2 + dy^2)) *zoomfact
function=r
end function
'
'
'------------------------------------------------------------------------
function shademdb(byval mthd as rendermeths,byval r as mdbrestype)
dim as single h,s,v
const limdea = 0.0057994 ' exp(-5.15)
select case as const mthd
case rndr_solar
if r.nit=1 then
h=60+log(r.strip)*120
s=65
v=60
elseif r.dea<=limdea then
h=120
s=50
v=16 -4.2* log(r.dea)
else
h=r.nit*50+r.par*180
s=80
v=45
end if
function=hsvtorgb(h,s,v)
end select
end function
'
'
'--------------------------------------------------------------------------
function rendermdb(byval offx as double,_
byval offy as double ,_
byval xwidth as double,_
byval maxit,_
byval mthd as rendermeths)
dim i,j,dea=1
dim as double x,y,inc,x0,y0,c
dim as integer ptr videopage
if xwidth=0 then xwidth=4
if maxit=0 then maxit=100
'get complex coord of tl corner, and pixel increment
x0=offx-(xwidth/2)
y0=offy+(xwidth/frel/2)
inc=xwidth/maxx
y=y0
screenlock
VideoPage=ScreenPtr
for j=1 to maxy
x=x0
screenlock
for i=1 to maxx
videopage[c]=shademdb(mthd,calcmdb(x,y,maxit,dea))
x+=inc:c+=1
next i
if (j and 15)=0 then
screenunlock j-16,j
sleep 0:
screenlock
if len(inkey$) then exit for
end if
y-=inc
next j
screenunlock
end function
'
'
'----------------------------------------------------------
sub launchmandel(xc as double,yc as double,xw as double,its,mthd)
dim t!
t!=timer
zoomfact=4/xw
windowtitle "x:"&xc &" y:"& yc &" Zoom:"&zoomfact
rendermdb(xc,yc,xw,its,mthd)
windowtitle(str$(timer-t!))
end sub
'
'
'----------------------------------------------------------------------------
dim t!
dim x,y,b,its,oldits,rndr
dim as double xc,yc,xw,oldxc,oldyc,oldxw,d1,d2
dim r as myrect
screenres maxx,maxy,32
xc=-0.5
yc=0
xw=4
its=200
rndr=rndr_solar
launchmandel(xc,yc,xw,its,rndr)
'end
do
sleep 50
getmouse x,y,,b
if b=1 then
oldxc=xc
oldyc=yc
oldxw=xw
oldits=its
r= boundbox(x,y)
xc=oldxc +oldxw/cdbl(maxx)*((r.x1+r.x0-maxx)/2.0)
yc=oldyc -oldxw/cdbl(maxx)*((r.y1+r.y0-maxy)/2.0)
d1=abs(r.x1-r.x0)/maxx
d2=abs(r.y1-r.y0)/maxy
xw=oldxw*iif(d1>d2,d1,d2)
zoomfact=4/xw
its=100*log(zoomfact)
launchmandel(xc,yc,xw,its,rndr)
elseif b=2 then
xc=oldxc
yc=oldyc
xw=oldxw
its=oldits
launchmandel(xc,yc,xw,its,rndr)
end if
loop until len(inkey$)
sleep
'----------------------------------------------------------------------------