Адрес: ул. Б. Очаковская 32 Москва Россия
Наши официальные канал и чат в telegram, группа в ВКонтакте

3D Surfaces

Работает на библиотеке для обработки изображений: bmp, pcx

Библиотеки и примеры программ на языке Yabasic
Аватара пользователя
Anton
Site Admin
Сообщения: 137
Зарегистрирован: Чт фев 08, 2024 7:03 pm
Откуда: Москва

3D Surfaces

Сообщение Anton »

3D Surfaces
Исходный код библиотеки image.yab:

Код: Выделить всё

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
Исходный код программы 3D Surfaces

Код: Выделить всё

// **************************************************************************
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

3DSurfaces.gif
У вас нет необходимых прав для просмотра вложений в этом сообщении.