Исходный код библиотеки image.yab:
Исходный код программы 3D Surfaces
Код: Выделить всё
doc image.yab
doc library for handling images: bmp, pcx
doc programmed by Herman H.M.M, E-mail: hh_mm@yahoo.com
doc how to use this?
doc first call
doc index = LoadImage(filename$)
doc then display the image calling
doc DrawImage(index, x, y)
doc you can see the image attributes, calling
doc image.Report(index)
debug=1 : rem flag variable to report more information
Path$="" : rem path from where to load images
Error$=""
ValidExt$="bmp,pcx" : rem missing gif, xbm. xpm, jpg
width=0
height=0
bpp=0
rem the palette can contain upto 256 colors
rem each with 4 bytes: R,G,B values and optional transparency
dim Pal(256*4)
maxImages=53 : rem 53 to be able to load a deck of playing cards images
dim Filename$(maxImages), Fp(maxImages), Type$(maxImages)
dim Width(maxImages), Height(maxImages), Bpp(maxImages)
imagec=0 : rem image counter
dim pixels(2,2)
sub exitError(m$)
beep
?:? m$
? "Press Enter to quit"
input ok$
exit
end sub
Sub Report(idx)
? : ? "Report on image loaded at index: [",idx,"]"
if idx>-1 then
? "image Filename = ", Filename$(idx)
? " image Width = ", Width(idx)
? " image Height = ", Height(idx)
? "Bits Per Pixel = ", Bpp(idx)
else
? " invalid index = ",idx
end if
? "Last Error = [", Error$,"]"
?
End Sub
sub GetExt$(filename$)
local r$, i
r$= right$(filename$,5)
i=instr(r$,".")
if i>0 then
return lower$(right$(r$,5-i))
else
return ""
end if
end sub
Export sub LoadImage(filename$, INDEX)
local fp, ext$, index
if(numparams>1) index=INDEX
if(numparams=1) index=imagec+1
if index>imagec imagec=index
if index<0 or index>maxImages then
exitError("image.LoadImage("+filename$+") invalid index ["+str$(index)+"]")
end if
fp=open( Path$+filename$ , "rb" )
if fp<1 exitError("File: "+filename$+" Does not Exist in path: ["+Path$+"]")
Filename$(index)=Path$+filename$
Fp(index)=fp
ext$=GetExt$(filename$)
if ext$<>"bmp" and ext$<>"pcx" then
exitError("image type: "+ext$+" is not supported")
end if
if ext$="bmp" then
ReadBmpHeader(index)
elsif ext$="pcx" then
ReadPcxHeader(index)
else
exitError("File format ["+ext$+"] not supported")
end if
if debug=1 Report(index)
return index
end sub
sub ReadBmpHeader(idx)
local fp
fp=Fp(idx)
seek #fp, 18
width = peek(fp)+256*peek(fp)
Width(idx) = width
seek #fp, 22
height = peek(fp)+256*peek(fp)
Height(idx)= height
seek #fp, 28
bpp = peek(fp)
Bpp(idx) = bpp
Type$(idx)="BMP"
rem +str$(bpp)
end sub
sub ReadPcxHeader(idx)
local fp
fp=Fp(idx)
seek #fp, 8
width=peek(fp)+256*peek(fp)
height=peek(fp)+256*peek(fp)
Width(idx)=width
Height(idx)=height
Type$(idx)="PCX"
Bpp(idx) = 8
end sub
sub LoadPalette(idx)
local fp
fp=Fp(idx)
type$=Type$(idx)
if type$="BMP" then
? "Loading BMP palette ..."
NumColors=256
seek #fp,54
for c=0 to 4*NumColors-1
Pal(c)=peek(fp)
next c
elsif type$="PCX" then
? "Loading PCX palette ..."
seek #fp, 0, "end"
seek #fp, -768 ,"end"
for i=0 to 767
Pal(i)=peek(#fp)
next i
end if
end sub
sub GetPalette(idx, palette())
local fp
fp=Fp(idx)
type$=Type$(idx)
if type$="BMP" then
? "Getting BMP palette ..."
NumColors=256
seek #fp,54
for c=0 to 4*NumColors-1
palette(c)=peek(fp)
next c
elsif type$="PCX" then
? "Getting PCX palette ..."
seek #fp, 0, "end"
seek #fp, -768 ,"end"
for i=0 to 767
palette(i)=peek(#fp)
next i
end if
end sub
export sub DrawImage(idx, x, y)
if debug=1 ? "drawing format = [", Type$(idx),"]"
if Type$(idx)="BMP" then
DrawBMP(idx, x, y)
elsif Type$(idx)="PCX" then
DrawPCX(idx, x, y)
else
exitError("Image format not supported")
end if
end sub
Export sub DrawFile( dx, dy, fn$ )
tmp=LoadImage(fn$, 0)
if tmp>-1 then
DrawImage(0, dx , dy)
else
beep
?:print " \n Error = ",Error$
?
wait 2
end if
end sub
Export Sub DrawPCX(idx, dx, dy )
local fp, i, flength
local x,y, pix,rle
fp=Fp(idx)
width=Width(idx)
height=Height(idx)
REM ************ GO TO END TO CHECK FILESIZE AND READ PALETTE *******
seek #fp, 0, "end"
flength=tell(#fp)
seek #fp, -768 ,"end"
for i=0 to 767
Pal(i)=peek(#fp)
next i
REM ************ READ Run Length Encoded Pixel Data ********
seek #fp, 128
rem for i=0 to flength-128-768
rem rle(i)=peek(#fp)
rem next i
for y=0 to height
x=0
while(x<= width)
pix=peek(#fp)
if pix>192 then
rle=pix-192
pix=3*peek(#fp)
color Pal(pix), Pal(pix+1), Pal(pix+2)
if x+rle>width+1 then
line dx+x,dy+y to dx+width, dy+y
y=y+1
x=x+rle-width-1
line dx,dy+y to dx+x,dy+y
else
line dx+x,dy+y to dx+x+rle,dy+y
x=x+rle
end if
else
color Pal(3*pix), Pal(3*pix+1),Pal(3*pix+2)
dot dx+x,dy+y
x=x+1
end if
wend
next y
End Sub : rem DrawPCX()
export sub DrawBMP( idx , dx, dy)
local fp, i,j, bytes, byte, rowbytes, offset
fp=Fp(idx)
bpp = Bpp(idx)
width=Width(idx)
height=Height(idx)
seek fp, 10 : offset=peek(fp)+256*peek(fp)
if bpp=4 or bpp=8 then
NumColors=2^bpp
rem Read the Color Palette, stores them in Pal()
rem values start at byte 55 in the file. Four bytes are stored
rem for each color, three for the blue, green and red values
rem and one for transparency which is not used.
seek #fp,54
for c=0 to 4*NumColors-1
Pal(c)=peek(fp)
next c
end if
if bpp = 4 goto DrawBmp4
if bpp = 8 goto DrawBmp8
if bpp =24 goto DrawBmp24
Label DrawBmp4
seek #fp,offset
rowbytes = int( ( bpp * width + 31) / 32) * 4
if debug=1 ? "bytes per row = ",rowbytes
for row = 0 to height-1
col = 0
bytes=0
while(bytes<rowbytes)
tmp=peek(fp)
bytes=bytes+1
if col<width then
byte=4*int(tmp/16)
color Pal(byte+2),Pal(byte+1),Pal(byte)
dot dx+col,dy+height-row-1
col=col+1
end if
if col<width then
byte=4*mod(tmp,16)
color Pal(byte+2),Pal(byte+1),Pal(byte)
dot dx+col,dy+height-row-1
col=col+1
end if
wend
next row
return
Label DrawBmp8
seek #fp,offset
for row = 0 to height-1
FOR col = 0 to width-1
byte=4*peek(fp)
color Pal(byte+2),Pal(byte+1),Pal(byte)
dot dx+col,dy+height-row-1
NEXT col
rem adjust extra bytes
c=width
while(mod(c,4)<>0)
tmp=peek(fp)
c=c+1
wend
next row
return
Label DrawBmp24
seek #fp,54
for row = 0 to height-1
FOR col = 0 to width-1
blue=peek(fp)
green=peek(fp)
color peek(fp),green,blue
dot dx+col,dy+height-row-1
NEXT col
rem adjust extra bytes
c=width*3
while(mod(c,4)<>0)
tmp=peek(fp)
c=c+1
wend
next row
end sub : rem DrawBMP()
export sub GetBmpPixels( idx, pixelsArray() )
Error$=""
if Type$(idx)<>"BMP" then
? "GetBmpPixels() only works with bmp images."
return
end if
fp=Fp(idx)
bpp=Bpp(idx)
width=Width(idx)
height=Height(idx)
seek fp, 10 : offset=peek(fp)+256*peek(fp)
dim pixelsArray(width,height)
IF bpp = 4 THEN
seek #fp,offset
rowbytes = int( ( bpp * width + 31) / 32) * 4
for row = 0 to height-1
col = 0
bytes=0
while(bytes<rowbytes)
tmp=peek(fp)
bytes=bytes+1
if col<width then
byte=4*int(tmp/16)
pixelsArray( col,row)=byte
col=col+1
end if
if col<width then
byte=4*mod(tmp,16)
pixelsArray(col,row)=byte
col=col+1
end if
wend
next row
ELSIF bpp= 8 THEN
seek #fp,offset
flagEOF=0
row = 0
while( row<height and flagEOF=0)
col = 0
repeat
byte=peek(fp) : if byte<0 flagEOF=1
pixelsArray(col,row)=4*byte
col=col+1
until( col>=width or flagEOF=1)
rem adjust extra bytes
c=width
while(mod(c,4)<>0)
tmp=peek(fp)
c=c+1
wend
if flagEOF=1 then
? "EOF at (row=",row, ", col=",col, ")"
end if
row=row+1
wend
ELSIF bpp=24 then
seek #fp,54
for row = 1 to height
FOR col = 1 to width
blue=peek(fp)
green=peek(fp)
red=peek(fp)
pixelsArray(col,height+1-row)=red+256*green+65536*blue
NEXT col
rem adjust extra bytes
c=width*3
while(mod(c,4)<>0)
tmp=peek(fp)
c=c+1
wend
next row
END IF
end sub
: rem GetBmpPixels()
Export sub LoadPixels(idx)
if Bpp(idx)<>8 or Type$(idx)<>"BMP" then
? "LoadPixels() only works with 8 bpp BMPs"
return
end if
GetBmpPixels(idx, pixels())
end sub
sub drawClip( a,b, w,h, dx, dy)
for j=b to b+h-1
for i=a to a+w-1
byte=pixels(i,j)
color Pal(byte+2),Pal(byte+1),Pal(byte)
dot dx+i-a, dy+h-(j-b)-1
next
next
end subКод: Выделить всё
// **************************************************************************
REM 3D Surfaces, adapted from DigameUK (John Fisher) program to Yabasic 2.768
// **************************************************************************
import image // author: Herman
clear screen
WindowWidth = 800
WindowHeight = 600
dx = 310
dy = 25
dim ColLookUp$(256, 12), v(12)
open window WindowWidth, WindowHeight
DrawFile(0,0,"QuadSpectrum.bmp")
for l = 1 to 11 // since the bmp has 11 graduated colour stripes
read yy // which is how far down next colour stripe is centred
v(l) = yy
for v = 0 to 255
pixcol$ = right$(getbit$(v,yy,v,yy), 6)
ColLookUp$(v, l) = str$(dec(left$(pixcol$,2))) + ", " + str$(dec(mid$(pixcol$,3,2))) + ", " + str$(dec(right$(pixcol$,2)))
next v
next l
text 100,300,"Press 'q' to quit."
text 85,350,"Other key to continue."
repeat
color 0,0,0 : fill rectangle 300,10 to 790,590 : color 255,255,255
c = mod(c + 1, 11) // choose in turn each of 11 colour sequences. ( c = 0 to 10)
ch = c + 1 // ch = 1 to 11
color 255,0,0 : fill circle 270, v(ch), 5
for y =199 to 0 step -1
for x =0 to 399
z =func(x, y)
color ColLookUp$(abs(z), ch)
line dx+x+y/4, dy+300-y/4+z, dx+x+y/4, dy+300-y/4
next x
next y
key$ = lower$(inkey$)
color 255,255,255 : fill circle 270, v(ch), 5
until(key$ = "q")
exit
data 5, 18, 33, 44, 53, 62, 80, 93, 105, 118, 129
sub func( x, y)
return 254 * sin(y/40) * sin(x/20) // range -254 to +254
end sub