This is a first attempt at a simple drawing program to make 10 such images.
It only has one pen color and one pen size at this stage without any other paint tools to keep it simple and as proof of concept.
Using keys:
key = "," back to previous frame
key = "." forward to next frame
key = "c" clear current frame
key = "s" save all frames
key = "l" Load any previously saved frames
key = "x" clear all frames
key = "z" start zooming. Stop using ESC key
key = "r" toggle between pen and rubber
The outer border is where you would normal draw for that is all that will be shown in each image with the inner parts being ever reduced versions of the following images. Images within images. I have modified it so you can draw within part of the inner rectangle where two of the following reduced images would be drawn to make it easier merge across the borders.
The images are drawn in perspective with the vanishing point in the center of the image. The diagonal guide lines may help to draw say a window or mat (river) in the correct perspective.
A simple first attempt might be a corridor by tracing over those four diagonal in each frame. Then you can add stuff into the corridor.
You can save the images to play or edit later. You can continually add things or erase them until happy with the result.
This was a quick crude example for the first frame to give you and idea.
It also uses Joshy's multikey.bi to reduce the size of the images.
multikey.bi
Code: Select all
' by D.J.Peters (Joshy)
' an put, scale, rotate hackfor the new ImageHeader format.
' MultiPut [destination],[xmidpos],[ymidpos],source,[xScale],[yScale],[Trans]
#define UseRad 'if not then Rotate are in degres
Sub MultiPut(Byval lpTarget As Any Ptr= 0, _
Byval xMidPos As Integer= 0, _
Byval yMidPos As Integer= 0, _
Byval lpSource As Any Ptr , _
Byval xScale As Single = 1, _
Byval yScale As Single = 1, _
Byval Rotate As Single = 0, _
Byval Trans As Integer= 0)
If (screenptr=0) Or (lpSource=0) Then Exit Sub
If xScale < 0.001 Then xScale=0.001
If yScale < 0.001 Then yScale=0.001
Dim As Integer MustLock,MustRotate
If lpTarget= 0 Then MustLock =1
If Rotate <>0 Then MustRotate=1
Dim as Integer TargetWidth,TargetHeight,TargetBytes,TargetPitch
If MustLock Then
ScreenInfo _
TargetWidth , _
TargetHeight, _
TargetBytes ,,_
TargetPitch
TargetBytes shr=3
lpTarget=ScreenPtr
Else
TargetBytes = cptr(uinteger Ptr,lpTarget)[1]
TargetWidth = cptr(uinteger Ptr,lpTarget)[2]
TargetHeight = cptr(uinteger Ptr,lpTarget)[3]
TargetPitch = cptr(uinteger Ptr,lpTarget)[4]
lpTarget += 32
End If
If (TargetWidth<4) Or (TargetHeight<4) Then Exit Sub
Dim As Integer SourceWidth,SourceHeight,SourceBytes,SourcePitch
if cptr(integer Ptr,lpSource)[0] = 7 then
SourceBytes = cptr(uinteger Ptr,lpSource)[1]
SourceWidth = cptr(uinteger Ptr,lpSource)[2]
SourceHeight = cptr(uinteger Ptr,lpSource)[3]
SourcePitch = cptr(uinteger Ptr,lpSource)[4]
lpSource += 32
else
SourceBytes = 1
SourceWidth = cptr(ushort Ptr,lpSource)[0] shr 3
SourceHeight = cptr(ushort Ptr,lpSource)[1]
SourcePitch = SourceWidth
lpSource += 4
end if
#if 0
? TargetWidth & "x" & TargetHeight & "x" & TargetBytes,TargetPitch
? SourceWidth & "x" & SourceHeight & "x" & SourceBytes,SourcePitch
? MustLock,Trans
sleep:end
#endif
If (SourceWidth<2) Or (SourceHeight<2) Then Exit Sub
If (TargetBytes<>SourceBytes) Then Exit Sub
#define xs 0 'screen
#define ys 1
#define xt 2 'texture
#define yt 3
Dim As Single Points(3,3)
points(0,xs)=-SourceWidth/2 * xScale
points(1,xs)= SourceWidth/2 * xScale
points(2,xs)= points(1,xs)
points(3,xs)= points(0,xs)
points(0,ys)=-SourceHeight/2 * yScale
points(1,ys)= points(0,ys)
points(2,ys)= SourceHeight/2 * yScale
points(3,ys)= points(2,ys)
points(1,xt)= SourceWidth-1
points(2,xt)= points(1,xt)
points(2,yt)= SourceHeight-1
points(3,yt)= points(2,yt)
Dim As Uinteger i
Dim As Single x,y
If MustRotate Then
#ifndef UseRad
Rotate*=0.017453292 'degre 2 rad
#endif
While Rotate< 0 :rotate+=6.2831853:Wend
While Rotate>=6.2831853:rotate-=6.2831853:Wend
For i=0 To 3
x=points(i,xs)*Cos(Rotate) - points(i,ys)*Sin(Rotate)
y=points(i,xs)*Sin(Rotate) + points(i,ys)*Cos(Rotate)
points(i,xs)=x:points(i,ys)=y
Next
End If
Dim As Integer yStart,yEnd,xStart,xEnd
yStart=100000:yEnd=-yStart:xStart=yStart:xEnd=yEnd
#define LI 0 'LeftIndex
#define RI 1 'RightIndex
#define IND 0 'Index
#define NIND 1 'NextIndex
Dim As Integer CNS(1,1) 'Counters
For i=0 To 3
points(i,xs)=Int(points(i,xs)+xMidPos)
points(i,ys)=Int(points(i,ys)+yMidPos)
If points(i,ys)<yStart Then yStart=points(i,ys):CNS(LI,IND)=i
If points(i,ys)>yEnd Then yEnd =points(i,ys)
If points(i,xs)<xStart Then xStart=points(i,xs)
If points(i,xs)>xEnd Then xEnd =points(i,xs)
Next
If yStart =yEnd Then Exit Sub
If yStart>=TargetHeight Then Exit Sub
If yEnd <0 Then Exit Sub
If xStart = xEnd Then Exit Sub
If xStart>=TargetWidth Then Exit Sub
If xEnd <0 Then Exit Sub
Dim As uByte Ptr t1,s1
Dim As uShort Ptr t2,s2
Dim As uInteger Ptr t4,s4
#define ADD 0
#define CMP 1
#define SET 2
Dim As Integer ACS(1,2) 'add compare and set
ACS(LI,ADD)=-1:ACS(LI,CMP)=-1:ACS(LI,SET)=3
ACS(RI,ADD)= 1:ACS(RI,CMP)= 4:ACS(RI,SET)=0
#define EX 0
#define EU 1
#define EV 2
#define EXS 3
#define EUS 4
#define EVS 5
Dim As Single E(2,6),S(6),Length,uSlope,vSlope
Dim As Integer U,UV,UA,UN,V,VV,VA,VN
' share the same highest point
CNS(RI,IND)=CNS(LI,IND)
If MustLock Then ScreenLock
' loop from Top to Bottom
While yStart<yEnd
'Scan Left and Right sides together
For i=LI To RI
' bad to read but fast and short ;-)
If yStart=points(CNS(i,IND),ys) Then
CNS(i,NIND)=CNS(i,IND)+ACS(i,Add)
If CNS(i,NIND)=ACS(i,CMP) Then CNS(i,NIND)=ACS(i,SET)
While points(CNS(i,IND),ys) = points(CNS(i,NIND),ys)
CNS(i, IND)=CNS(i,NIND)
CNS(i,NIND)=CNS(i, IND)+ACS(i,Add)
If CNS(i,NIND)=ACS(i,CMP) Then CNS(i,NIND)=ACS(i,SET)
Wend
E(i,EX) = points(CNS(i, IND),xs)
E(i,EU) = points(CNS(i, IND),xt)
E(i,EV) = points(CNS(i, IND),yt)
Length = points(CNS(i,NIND),ys)
Length -= points(CNS(i, IND),ys)
If Length <> 0.0 Then
E(i,EXS) = points(CNS(i, NIND),xs)-E(i,EX):E(i,EXS)/=Length
E(i,EUS) = points(CNS(i, NIND),xt)-E(i,EU):E(i,EUS)/=Length
E(i,EVS) = points(CNS(i, NIND),yt)-E(i,EV):E(i,EVS)/=Length
End If
CNS(i,IND)=CNS(i,NIND)
End If
Next
If (yStart<0) Then Goto SkipScanLine
xStart=E(LI,EX)+0.5:If xStart>=TargetWidth Then Goto SkipScanLine
xEnd =E(RI,EX)-0.5:If xEnd < 0 Then Goto SkipScanLine
If (xStart=xEnd) Then Goto SkipScanLine
'if xEnd <xStart then goto SkipScanLine
Length=xEnd-xStart
uSlope=E(RI,EU)-E(LI,EU):uSlope/=Length
vSlope=E(RI,EV)-E(LI,EV):vSlope/=Length
If xstart<0 Then
Length=Abs(xStart)
U=Int(E(LI,EU)+uSlope*Length)
V=Int(E(LI,EV)+vSlope*Length)
xStart = 0
Else
U=Int(E(LI,EU)):V=Int(E(LI,EV))
End If
If xEnd>=TargetWidth Then xEnd=TargetWidth-1
UV=Int(uSlope):UA=(uSlope-UV)*100000:UN=0
VV=Int(vSlope):VA=(vSlope-VV)*100000:VN=0
xEnd-=xStart
Select Case TargetBytes
Case 1
t1=cptr(ubyte ptr,lpTarget)
t1+=yStart*TargetPitch+xStart:xStart=0
If Trans=0 Then
While xStart<xEnd
s1=lpSource+V*SourcePitch+U
*t1=*s1
U+=UV:UN+=UA:If UN>=100000 Then U+=1:UN-=100000
V+=VV:VN+=VA:If VN>=100000 Then V+=1:VN-=100000
If u<0 Then u=0
If v<0 Then v=0
xStart+=1:t1+=1
Wend
Else
While xStart<xEnd
s1=lpSource+V*SourcePitch+U
If *s1 Then *t1=*s1
U+=UV:UN+=UA:If UN>=100000 Then U+=1:UN-=100000
V+=VV:VN+=VA:If VN>=100000 Then V+=1:VN-=100000
If u<0 Then u=0
If v<0 Then v=0
xStart+=1:t1+=1
Wend
End If
Case 2
t2=cptr(Short Ptr,lpTarget)
t2+=yStart*(TargetPitch shr 1)+xStart:xStart=0
If Trans=0 Then
While xStart<xEnd
s2=cptr(Short Ptr,lpSource)+V*(SourcePitch shr 1)+U
*t2=*s2
U+=UV:UN+=UA:If UN>=100000 Then U+=1:UN-=100000
V+=VV:VN+=VA:If VN>=100000 Then V+=1:VN-=100000
If u<0 Then u=0
If v<0 Then v=0
xStart+=1:t2+=1
Wend
Else
While xStart<xEnd
s2=cptr(Short Ptr,lpSource)+V*(SourcePitch shr 1)+U
If *s2<>&HF81F Then *t2=*s2
U+=UV:UN+=UA:If UN>=100000 Then U+=1:UN-=100000
V+=VV:VN+=VA:If VN>=100000 Then V+=1:VN-=100000
If u<0 Then u=0
If v<0 Then v=0
xStart+=1:t2+=1
Wend
End If
Case 4
t4=cptr(Integer Ptr,lpTarget)+yStart*(TargetPitch shr 2)+xStart:xStart=0
If Trans=0 Then
While xStart<xEnd
s4=cptr(Integer Ptr,lpSource)+V*(SourcePitch shr 2)+U
*t4=*s4
U+=UV:UN+=UA:If UN>=100000 Then U+=1:UN-=100000
V+=VV:VN+=VA:If VN>=100000 Then V+=1:VN-=100000
If u<0 Then u=0
If v<0 Then v=0
xStart+=1:t4+=1
Wend
Else
While xStart<xEnd
's4=cptr(Integer Ptr,lpSource):s4+=V*(SourcePitch shr 2):s4+=U
s4=cptr(Integer Ptr,lpSource)+V*(SourcePitch shr 2)+U
If *s4<>&HFFFF00FF Then *t4=*s4
U+=UV:UN+=UA:If UN>=100000 Then U+=1:UN-=100000
V+=VV:VN+=VA:If VN>=100000 Then V+=1:VN-=100000
If u<0 Then u=0
If v<0 Then v=0
xStart+=1:t4+=1
Wend
End If
End Select
SkipScanLine:
E(LI,EX)+=E(LI,EXS):E(LI,EU)+=E(LI,EUS):E(LI,EV)+=E(LI,EVS)
E(RI,EX)+=E(RI,EXS):E(RI,EU)+=E(RI,EUS):E(RI,EV)+=E(RI,EVS)
yStart+=1:If yStart=TargetHeight Then yStart=yEnd 'exit loop
Wend
If MustLock Then ScreenUnlock
End Sub
zoomPainter.bas
Code: Select all
#include "multiput.bi"
#define scr_w 640 'change it
#define scr_h 480
#define wh scr_w\2
#define hh scr_h\2
sub drawLine(img as any ptr, x1 As Integer,y1 As Integer,x2 As Integer,y2 As Integer,pSize As Integer,pColor As UInteger)
dim as integer x,y
if x1 = x2 and y1 = y2 then
circle img,(x1, y1), pSize, pColor, , , , f
elseif abs(x2 - x1) >= abs(y2 - y1) then
dim K as Single = (y2 - y1) / (x2 - x1)
for I as Integer = x1 To x2 step sgn(x2 - x1)
x = I
y = K * (I - x1) + y1
circle img,(x,y), pSize, pColor, , , , f
next I
else
dim L as Single = (x2 - x1) / (y2 - y1)
for J as Integer = y1 To y2 step sgn(y2 - y1)
x = L * (J - y1) + x1
y = J
circle img,(x,y), pSize,pColor,,,,f
next J
end if
end sub
screenres 640,480,32
color rgb(0,0,0),rgb(255,255,255):cls
dim shared as integer mx,my,mb,ox,oy
SetMouse(0,0,1,1)
dim shared as integer frame,frame2,frame3
frame = 0
dim shared as any ptr image(0 to 9) 'working images
dim shared as any ptr image2(0 to 9) 'final images
dim shared as ulong penColor
dim shared as integer penSize
dim shared as integer rub 'small black pen or large white pen
for i as integer = 0 to 9
image(i) = imagecreate(641,481,rgb(255,255,255))
image2(i) = imagecreate(641,481,rgb(255,255,255))
next i
sub drawImages()
dim as integer ii
dim as single xZoom,yZoom
xZoom = 1
yZoom = 1
screenlock
cls
for i as integer = frame to frame + 7
if i > 9 then ii = i-10 else ii = i
multiput (0,320,240,image(ii),xZoom,yZoom,0,0)
xZoom = xZoom/2
yZoom = yZoom/2
next i
line (159,119)-(478,358),rgb(0,0,0),b 'draw inner area border
line (0,0)-(639,479),rgb(0,0,0),b 'draw outer border
line (159,119)-(0,0),rgb(0,0,0) 'top left
line (478,119)-(639,0),rgb(0,0,0) 'top right
line (159,358)-(0,479),rgb(0,0,0) 'bottom left
line (478,358)-(639,479),rgb(0,0,0) 'bottom right
locate 2,2
print "frame:";frame
locate 4,2
if rub = 0 then
print "Pen ON"
else
print "RUBBER ON"
end if
screenunlock
end sub
sub createImages()
dim as integer ii
dim as single xZoom,yZoom
xZoom = 1
yZoom = 1
for j as integer = 0 to 9
xZoom = 1
yZoom = 1
for i as integer = j to j + 7
if i > 9 then ii = i-10 else ii = i
' MultiPut [destination],[xmidpos],[ymidpos],source,[xScale],[yScale],[Trans]
multiput (image2(j),320,240,image(ii),xZoom,yZoom,0,0)
xZoom = xZoom/2
yZoom = yZoom/2
next i
' cls
' put (0,0),image2(j),trans
bsave "image" & str(j) & ".bmp",image2(j)
next j
end sub
sub loadImages()
for i as integer = 0 to 9
bload "image" & str(i) & ".bmp",image(i)
next i
end sub
sub saveImages()
for i as integer = 0 to 9
bsave "image" & str(i) & ".bmp",image(i)
next i
end sub
sub clearAllImages()
for i as integer = 0 to 9
line image(i),(0,0)-(639,479),rgb(255,255,255),bf
next i
frame = 0
end sub
sub zoomImages()
createImages() 'have to create 10 images to zoom
color rgb(255,0,0)
dim as single xZoom1,yZoom1
dim as integer imgFrame
xZoom1 = 1
yZoom1 = 1
imgFrame = 0
do
screenlock
cls
xZoom1 = xZoom1 + .01
yZoom1 = yZoom1 + .01
MultiPut(,320,240,image2(imgFrame),xZoom1,yZoom1,0,1) ',1=trans
locate 1,1
print imgFrame,xZoom1
screenunlock
if xZoom1 > 2 then
imgFrame = imgFrame + 1
xZoom1 = 1
yZoom1 = 1
if imgFrame = 10 then imgFrame = 0
end if
Sleep 10
loop until multikey(&H01)
while multikey(&H01):wend
color rgb(0,0,0)
end sub
dim as string key
do
drawImages()
getmouse mx,my,,mb
frame2 = frame + 1
if frame2>9 then frame2 = 0
frame3 = frame2 + 1
if frame3>9 then frame3 = 0
if rub = 0 then
penColor = rgb(0,0,0)
penSize = 5
else
penColor = rgb(255,255,255)
penSize = 10
end if
if mb=1 then
ox = mx
oy = my
while mb=1
getmouse mx,my,,mb
if mx<>ox or my<>oy then
'line image(frame),(ox,oy)-(mx,my),rgb(0,0,0)
drawLine (image(frame),ox,oy,mx,my,penSize,penColor)
if mx>159 and mx<479 and my>119 and my<358 then
drawLine (image(frame2),ox*2-320,oy*2-240,mx*2-320,my*2-240,penSize,penColor)
end if
if mx>238 and mx<397 and my>179 and my<298 then
drawLine (image(frame3),(ox-240)*4,(oy-180)*4,(mx-240)*4,(my-180)*4,penSize,penColor)
end if
drawImages()
end if
ox = mx
oy = my
sleep 2
wend
end if
key = inkey
if key = "," then frame = frame - 1
if key = "." then frame = frame + 1
if frame<0 then frame = 9
if frame>9 then frame = 0
if key = "c" then line image(frame),(0,0)-(639,479),rgb(255,255,255),bf
if key = "s" then saveImages()
if key = "l" then loadImages()
if key = "x" then clearAllImages()
if key = "z" then zoomImages()
if key = "r" then
if rub = 1 then rub = 0 else rub = 1
end if
sleep 2
loop until multikey(&H01)
sleep