!!! only an hack not all situations tested !!!
Joshy
Code: Select all
' (c) D.J.Peters (Joshy)
' an put and scale hack :-)
' puts [destination],[xpos],[ypos],source,[scale]
' EXAMPLES:
' puts ,,,source
' puts ,,,source,0.5
' puts ,,,source,10
' puts ,10,50,source,20
' puts destination,,,source
' puts destination,10,20,source,0.5
' puts destination,,20,source,5
' puts destination,10,,source,50
option explicit
enum PtrSize
s8 =1
s16=2
s32=4
end enum
sub MultiLine(byval lpDes as any ptr,byval deswidth as integer, _
byval lpSrc as any ptr,byval srcwidth as integer, _
byval size as PtrSize)
dim as integer d,s,xv,xn,nadd
dim as ubyte ptr lpD8 ,lpS8
dim as ushort ptr lpD16,lpS16
dim as uinteger ptr lpD32,lpS32
dim as single xs
xs=srcwidth/deswidth:xv=int(xs):nadd=(xs-xv)*10000
select case size
case s8
lpD8=cptr(ubyte ptr,lpDes):lpS8=cptr(ubyte ptr,lpSrc)
while d<deswidth
lpD8[d]=lpS8[s]:d+=1:s+=xv:xn+=nadd:if xn>10000 then s+=1:xn-=10000
wend
case s16
lpD16=cptr(ushort ptr,lpDes):lpS16=cptr(ushort ptr,lpSrc)
while d<deswidth
lpD16[d]=lpS16[s]:d+=1:s+=xv:xn+=nadd:if xn>10000 then s+=1:xn-=10000
wend
case s32
lpD32=cptr(uinteger ptr,lpDes):lpS32=cptr(uinteger ptr,lpSrc)
while d<deswidth
lpD32[d]=lpS32[s]:d+=1:s+=xv:xn+=nadd:if xn>10000 then s+=1:xn-=10000
wend
end select
end sub
sub puts(byval lpDes as any ptr=0, _
byval xpos as integer=0, _
byval ypos as integer=0, _
byval lpSrc as any ptr , _
byval scale as single =1.0)
dim as short tmp,flag
dim as short ptr shortptr
dim as byte ptr anydes,anysrc
dim as integer xmax,ymax,bytesmax
dim as integer xsrc,ysrc,wsrc,hsrc,bytessrc
dim as integer wdes,hdes,yv,nadd,yn
dim as single ys,xstep,ystep
if screenptr=0 then exit sub 'nothing to do
if scale <0.0001 then exit sub 'wrong scale multiply
if xpos<0 or ypos<0 then exit sub
'get destination args
if lpDes<>0 then 'render to image
anydes =cptr(byte ptr,lpDes):shortptr=cptr(short ptr,lpDes)
tmp=shortptr[0]:bytesmax=tmp and &H0007:xmax=tmp shr 3
tmp=shortptr[1]:ymax=tmp:anydes+=4 'remove header
else ' render to curent workpage
screeninfo xmax,ymax,bytesmax
bytesmax=bytesmax shr 3:anydes=screenptr():flag=1 'for screenlock/unlock
end if
'out of clipping region
if (xpos>=xmax) or (ypos>=ymax) then exit sub
'get source args
anysrc =cptr(byte ptr,lpSrc): shortptr=cptr(short ptr,lpSrc)
tmp=shortptr[0]:bytessrc=tmp and &H0007:wsrc=tmp shr 3
tmp=shortptr[1]:hsrc=tmp:anysrc+=4 'remove header
'difrent bpp
if bytesmax <> bytessrc then exit sub
'get new dimensions
wdes=int(wsrc*scale):hdes=int(hsrc*scale)
'target shorter than one pixel
if (wdes<1) or (hdes<1) then exit sub
'right bottom clipping
if (xpos+wdes)>=(xmax-1) then wdes=(xmax-1)-xpos
if (ypos+hdes)>=(ymax-1) then hdes=(ymax-1)-ypos
if (wdes<1) or (hdes<1) then exit sub ' target shorter than one pixel
'adjust params
ys=hsrc/hdes:yv=int(ys):nadd=(ys-yv)*10000
anydes+=(xpos*bytesmax)
anydes+=(ypos*xmax*bytesmax)
if flag then screenlock
while hdes>0
hdes-=1
MultiLine anydes,wdes,anysrc,wsrc,bytesmax
anydes+=xmax*bytesmax
anysrc+=(yv*wsrc*bytesmax)
yn+=nadd:if yn>10000 then anysrc+=wsrc*bytesmax:yn-=10000
wend
if flag then screenunlock
end sub
'
' main
'
dim as any ptr source
dim as single zoom,w
screenres 640,480
? "FreeBASIC"
source =ImageCreate(72,8)
get (0,0)-(71,7),source
cls
for zoom=0.1 to 50 step 0.1
puts ,,,source,zoom
sleep 10,1
next
cls
while len(inkey)=0
puts ,sin(w)*100+100,cos(w*2)*100+100,source,sin(w)*10+10:w+=0.01
sleep 10,1:cls
wend
sleep