Drawing Zooming Images

User projects written in or related to FreeBASIC.
Post Reply
BasicCoder2
Posts: 3906
Joined: Jan 01, 2009 7:03
Location: Australia

Drawing Zooming Images

Post by BasicCoder2 »

After looking at some zooming image examples I wondered how they actually drew them.
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.

Image

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

UEZ
Posts: 972
Joined: May 05, 2017 19:59
Location: Germany

Re: Drawing Zooming Images

Post by UEZ »

If you interested in creating procedural infinite zoom graphics then check this out: http://infinitezoom.net/. A deeper look to the zoom.js source code might inspire you. ;-)
BasicCoder2
Posts: 3906
Joined: Jan 01, 2009 7:03
Location: Australia

Re: Drawing Zooming Images

Post by BasicCoder2 »

My interest was more in seeing if I could write the code for a paint program to make it easy to create these zoom graphics.
This was all just a puzzle to solve for me I doubt I would spend too much time on drawing images myself.

Although I have looked at some JavaScript tutorials I found it all a bit messy compared with a stand alone program.
If the image below is copied to all the frames (saved by the program key "s") it is another demo.
Right click the image below and Save As ... corridor.jpg then load into a Paint program and save as a bitmap file, image0.bmp, into the same folder as the program below. Then run this program and it will copy the image into all the other images.

Code: Select all

screenres 640,480,32
bload "image0.bmp"
for i as integer = 1 to 9
  bsave "image" & str(i) & ".bmp",0
next i
Then run the zoomPainter program.
Then press the "z" key.

You can then edit the images however you like.
Also I see no reason simple animation could not also be implemented.

Nikolaus Baumgarten used GIMP and Sophia Schomberg used Photoshop. The animation was then created with Javascript.

Image
Post Reply