TheGameCreators - CodeBase - fubars workshop

Return to the CodeBase listing

Category: Complete Applications

Version: 1.3

Information

Uploaded: 12th Nov 2005 05:28

Modified: 26th Nov 2005 07:06

Author: fubarpk

Summary

This program uses several graphic effects to create a picture that can be saved

Full Description

There are functions that I created and many i found on the forum and modified to suit. The idea is select a color then a shape and then an effect. Pictures may be saved. In this version there is no undo and if you click the save button no message is given it just does it. Polys randomly draws a poly shape with chosen color range, color colors object with chosen color, greyscale does just that, invert the colors with invert, remove red blue or green color channels or brighten or darken image. There is also a neat distort function found on the forum. many functions use memblocks for faster responses. for the shapes effect to work your video card must support the set sprite alpha and the set sprite diffuse command. The thumbnail was created in the program using the poly button but the kaleidoscope effect was done with a filter for photoshop. I really would like a routine to do this. So far I have learnt a kaleidoscope is an image on a plane with a heap of mirrors systematically placed at an angle so as to reflect the image back at itself. I am still playing with this idea not yet implimented.

DarkBASIC Professional Source Code

` This code was downloaded from The Game Creators

` It is reproduced here with full permission

` http://www.thegamecreators.com

REM Project: Workshop

REM Created: 14/10/2005 4:36:17 AM

REM

REM ***** Main Source File *****

REM

set current bitmap 0

if check display mode(800,600,32)=1

set display mode 800,600,32

else

cls rgb(0,0,0)

print "You need a better graphic card!!!"

print "One that supports 800*600 and atleast 16bit hi-colour mode"

print "32 bit or 24 bit colour recommended"

print "Press a key to exit"

wait key

end

endif

type __FloodFillType

Initialised as integer

CoverColour as integer

BitmapWidth as integer

BitmapHeight as integer

endtype

global __FloodFillGlobal as __FloodFillType

#constant __SpanListSize 15

type __FillSpan

Left as integer

Right as integer

endtype

global dim __FilledSpans() as __FillSpan

global dim __FilledSpansCount() as integer

sync rate 1000

sync on

RANDOMIZE timer()

load image "GraphicsRainbow.bmp",10,1

load image "GraphicsButtons.bmp",20,1

load image "GraphicsButtons2.bmp",25,1

load image "GraphicsButtons3.bmp",26,1

load image "GraphicsTitle.bmp",30,1

load bitmap "GraphicsCircles.bmp",100

load bitmap "GraphicsSquares.bmp",101

load bitmap "GraphicsPolys.bmp",102

load bitmap "GraphicsStars.bmp",103

load bitmap "GraphicsHearts.bmp",104

load bitmap "GraphicsAll.bmp",105

create bitmap 1,600,340

copy bitmap 100,1

set current bitmap 1

get image 1,0,0,199,84,1

get image 2,200,0,399,84,1

get image 3,400,0,599,84,1

get image 4,0,85,199,169,1

get image 5,200,85,399,169,1

get image 6,400,85,599,169,1

get image 7,0,0,599,339,1

set current bitmap 0

canSave as boolean

canSave=0

fillcolor as dword

fillcolor=rgb(255,255,255)

ink fillcolor,rgb(0,0,0)

repeat

paste image 10,0,0

paste image 20,0,192

paste image 25,0,343

paste image 30,200,0

paste image 26,200,70

if mouseclick()=1

if mousex()<=175 and mousey()<=166

fillcolor=point(mousex(),mousey())

ink rgb(0,0,0),rgb(0,0,0)

box 0,0,800,600

set current bitmap 1

gosub fillShapes

set current bitmap 0

paste image 7,200,250,1

endif

if mousex()<192 and mousey()>191 and mousey()<319

ink rgb(0,0,0),rgb(0,0,0)

box 0,0,800,600

if mousex()<64 and mousey()<255 then copy bitmap 100,1:rem circle

if mousex()>63 and mousex()<128 and mousey()<255 then copy bitmap 101,1:rem square

if mousex()>127 and mousey()<255 then copy bitmap 102,1:rem poly

if mousex()<64 and mousey()>254 then copy bitmap 103,1:rem star

if mousex()>63 and mousex()<128 and mousey()>254 then copy bitmap 104,1:rem heart

if mousex()>127 and mousey()>254 then copy bitmap 105,1:rem all

set current bitmap 1

gosub fillShapes

set current bitmap 0

paste image 7,200,250,1

endif

if mousex()<128 and mousey()>342 and mousey()<600

if mousey()<375 then wait 400:gosub dodisplay:sync:ink rgb(0,0,0),rgb(0,0,0):box 0,0,800,600:sync:wait 500:rem preview

if mousey()>374 and mousey()<408 then gosub doPoly:sync:ink rgb(0,0,0),rgb(0,0,0):box 0,0,800,600:sync:wait 500:rem dopoly

if mousey()>407 and mousey()<440 and canSave=1 then wait 400:color_image(200,rgbr(fillcolor),rgbg(fillcolor),rgbb(fillcolor)):sync:ink rgb(0,0,0),rgb(0,0,0):box 0,0,800,600:sync:wait 500:rem color change

if mousey()>439 and mousey()<472 and canSave=1 then wait 400:greyscale_image(200):sync:ink rgb(0,0,0),rgb(0,0,0):box 0,0,800,600:sync:wait 500:rem greyscale change

if mousey()>471 and mousey()<504 and canSave=1 then wait 400:invert_image(200):sync:ink rgb(0,0,0),rgb(0,0,0):box 0,0,800,600:sync:wait 500:rem invertImage

if mousey()>503 and mousey()<536 then wait 400:gosub distort:sync:ink rgb(0,0,0),rgb(0,0,0):box 0,0,800,600:sync:wait 500:rem distort

if mousey()>535 and mousey()<568 and canSave=1 then wait 400:savePic("OutputOutput"):canSave=0:rem save

if mousey()>567 then end:rem end

endif

if mousex()>199 and mousex()<329 and mousey()>69 and mousey()<166

if mousey()<102 and canSave=1 then wait 400:remove_colorchannel(200,1):sync:ink rgb(0,0,0),rgb(0,0,0):box 0,0,800,600:sync:wait 500:rem remove red colour

if mousey()>101 and mousey()<134 and canSave=1 then wait 400:remove_colorchannel(200,2):sync:ink rgb(0,0,0),rgb(0,0,0):box 0,0,800,600:sync:wait 500:rem remove blue color

if mousey()>133 and mousey()<166 and canSave=1 then wait 400:remove_colorchannel(200,3):sync:ink rgb(0,0,0),rgb(0,0,0):box 0,0,800,600:sync:wait 500:rem remove green color

endif

if mousex()>328 and mousex()<456 and mousey()>69 and mousey()<134

if mousey()<102 and canSave=1 then wait 400:brighten_darken(200,20,1):sync:ink rgb(0,0,0),rgb(0,0,0):box 0,0,800,600:sync:wait 500:rem remove red colour

if mousey()>101 and mousey()<134 and canSave=1 then wait 400:brighten_darken(200,20,0):sync:ink rgb(0,0,0),rgb(0,0,0):box 0,0,800,600:sync:wait 500:rem remove blue color

endif

paste image 7,200,250,1

sync

until escapekey()

dodisplay:

ink rgb(0,0,0),rgb(0,0,0):box 0,0,800,600:sync

myImage=(rnd(5)+1)

scale=(rnd(100)):alpha=(rnd(255)):xOffset#=(scale/100)*200:yOffset#=(scale/100)*170

xPos=(rnd(600-xOffset#)+xOffset#):yPos=(rnd(600-yOffset#)+yOffset#)

redValue=(rnd(255)):blueValue=(rnd(255)):greenValue=(rnd(255))

sprite 1,xPos,yPos,myImage

show sprite 1

SET SPRITE ALPHA 1,alpha

SET SPRITE DIFFUSE 1,redValue,blueValue,greenValue

scale sprite 1,scale

set sprite 1,0,1

repeat

myImage=(rnd(5)+1)

scale=(rnd(100)):alpha=(rnd(255)):xOffset#=(scale/100)*200:yOffset#=(scale/100)*170

xPos=(rnd(600-xOffset#)+xOffset#):yPos=(rnd(600-yOffset#)+yOffset#)

redValue=(rnd(200)+55):blueValue=(rnd(200)+55):greenValue=(rnd(200)+55)

sprite 1,xPos,yPos,myImage

SET SPRITE ALPHA 1,alpha

SET SPRITE DIFFUSE 1,redValue,blueValue,greenValue

scale sprite 1,scale

sync

until mouseclick()=1

get image 200,0,0,799,599,1

canSave=1

hide all sprites

return

fillShapes:

red=rgbr(fillcolor):green=rgbg(fillcolor):blue=rgbb(fillcolor)

oldred=red:oldgreen=green:oldblue=blue

floodfill(100,85,fillcolor)

`red=red+15 MOD 255:green=green+15 MOD 255:blue=blue+15 MOD 255

red=red+15:green=green+15:blue=blue+15

if red>255 then red=oldred

if green>255 then green=oldgreen

if blue>255 then blue=oldblue

floodfill(300,85,rgb(red,green,blue))

`red=red+15 MOD 255:green=green+15 MOD 255:blue=blue+15 MOD 255

red=red+15:green=green+15:blue=blue+15

if red>255 then red=oldred

if green>255 then green=oldgreen

if blue>255 then blue=oldblue

floodfill(500,85,rgb(red,green,blue))

`red=red+15 MOD 255:green=green+15 MOD 255:blue=blue+15 MOD 255

red=red+15:green=green+15:blue=blue+15

if red>255 then red=oldred

if green>255 then green=oldgreen

if blue>255 then blue=oldblue

floodfill(100,255,rgb(red,green,blue))

`red=red+15 MOD 255:green=green+15 MOD 255:blue=blue+15 MOD 255

red=red+15:green=green+15:blue=blue+15

if red>255 then red=oldred

if green>255 then green=oldgreen

if blue>255 then blue=oldblue

floodfill(300,255,rgb(red,green,blue))

red=red+15:green=green+15:blue=blue+15

if red>255 then red=oldred

if green>255 then green=oldgreen

if blue>255 then blue=oldblue

`red=red+15 MOD 255:green=green+15 MOD 255:blue=blue+15 MOD 255

floodfill(500,255,rgb(red,green,blue))

get image 1,0,0,199,84,1

get image 2,200,0,399,84,1

get image 3,400,0,599,84,1

get image 4,0,85,199,169,1

get image 5,200,85,399,169,1

get image 6,400,85,599,169,1

get image 7,0,0,599,339,1

return

function FloodFill(x,y,c)

__FloodFillGlobal.BitmapWidth=bitmap width()-1

__FloodFillGlobal.BitmapHeight=bitmap height()-1

__InitialiseFillSpan()

if x >= 0 and x <= __FloodFillGlobal.BitmapWidth

if y >= 0 and y <= __FloodFillGlobal.BitmapHeight

lock pixels

__FloodFillGlobal.CoverColour = point(x,y)

if __FloodFillGlobal.CoverColour <> c

ink c,0

__FloodLoop(x,y)

endif

unlock pixels

endif

endfunction

function __FloodLoop(x as integer,y as integer)

local Left as integer

local Right as integer

local SpanSize as integer

for Left=x-1 to 0 step -1

if point(Left,y) <> __FloodFillGlobal.CoverColour then exit

next Left

inc Left

for Right=x+1 to __FloodFillGlobal.BitmapWidth

if point(Right,y) <> __FloodFillGlobal.CoverColour then exit

next Right

` draw this line

box Left,y,Right,y+1

` and remember it

__AddFillSpan(y,Left-1,Right+1)

` Fill upwards

if y > 0

dec y

x=Left

while x < Right

SpanSize=__CheckFillSpan(x,y)

if SpanSize = 0

if point(x,y) = __FloodFillGlobal.CoverColour

__FloodLoop(x,y)

endif

inc x

else

inc x,SpanSize

endif

endwhile

inc y

endif

` Fill downwards

if y < __FloodFillGlobal.BitmapHeight

inc y

x=Left

while x < Right

SpanSize=__CheckFillSpan(x,y)

if SpanSize = 0

if point(x,y) = __FloodFillGlobal.CoverColour

__FloodLoop(x,y)

endif

inc x

else

inc x,SpanSize

endif

endwhile

endif

endfunction

function __InitialiseFillSpan()

local i as integer

if __FloodFillGlobal.Initialised = 0

` First time called, create the arrays - bigger than we should ever need

undim __FilledSpans()

global dim __FilledSpans(__SpanListSize,2048) as __FillSpan

undim __FilledSpansCount()

global dim __FilledSpansCount(2048) as integer

__FloodFillGlobal.Initialised=1

else

` Subsequent call, just reset the spans we'll be using

for i=__FloodFillGlobal.BitmapHeight to 0 step -1

__FilledSpansCount(i)=0

next i

endif

endfunction

function __AddFillSpan(y as integer,Left as integer,Right as integer)

local i as integer

i=__FilledSpansCount(y)

if i < __SpanListSize

__FilledSpans(i, y).Left=Left

__FilledSpans(i, y).Right=Right

inc __FilledSpansCount(y)

endif

endfunction

function __CheckFillSpan(x as integer,y as integer)

local i as integer

for i=__FilledSpansCount(y)-1 to 0 step -1

if x >= __FilledSpans(i, y).Left

if x < __FilledSpans(i, y).Right then exitfunction __FilledSpans(i, y).Right-x

endif

next i

endfunction 0

function savePic(filename$)

t=0:flag=1:newFilename$=filename$

while flag=1

if FILE EXIST(newFilename$+".bmp")

newFilename$=filename$+str$(t)

else

flag=0:newFilename$=newFilename$+".bmp"

save image newFilename$,200

endif

inc t,1

endwhile

delete image 200

endfunction

distort:

show all sprites

if sprite exist(1)=1 then hide sprite 1

if sprite Exist(301)=0

create bitmap 2,800,600

paste image 200,0,0,1

bw=bitmap width(2)

bh=bitmap height(2)

if bh<=16 or bw<=16

print "BMP too small to distort properly"

endif

`   Change the Z value for a smoother distortion effect

`   it must be a multiple of 2 (i.e. 2, 4, 6, 8, 16)

z=2 : y=0

`   Let's grab our sprites!

set current bitmap 2

for i=1 to bh/z-1

get image i+300,0,y,bw,y+z

sprite i,-100,-100,i+300

set sprite i,0,1

inc y,z

next i

delete bitmap 2

endif

`   Set-up the initial values

count=bh/z-1 : mystep=1 : speed=4 : sx=0

offsetx=(screen width()-bw)/2

offsety=(screen height()-bh)/2

set current bitmap 0

repeat

cls 0

lasttime=timer()

for a=1 to count

sprite a,offsetx+cos(wrapvalue(sx+a*mystep))*100,offsety+(a*z),a+300

next a

repeat

until timer()>lasttime+10

inc sx,speed

if upkey()

inc speed

if speed>64 then speed=64

endif

if downkey()

dec speed

if speed<0 then speed=0

endif

if leftkey()

inc mystep

if mystep>16 then mystep=16

endif

if rightkey()

dec mystep

if mystep<0 then mystep=0

endif

if spacekey() then end

sync

until mouseclick()=1

get image 200,0,0,799,599,1

canSave=1

hide all sprites

return

doPoly:

x=400:y=300

set current bitmap 0

hide all sprites

cls rgb(0,0,0)

red=rgbr(fillcolor):green=rgbg(fillcolor):blue=rgbb(fillcolor)

sides = rnd(7)+3:radius=0:oldred=red:oldgreen=green:oldblue=blue

while radius<300

inc radius,2

`red=red+2 MOD 255:green=green+2 MOD 255:blue=blue+2 MOD 255

red=red+2:green=green+2:blue=blue+2

`if red>255 or green>255 or blue>255 then red=oldred:green=oldgreen:blue=oldblue

if red>255 then red=oldred

if green>255 then green=oldgreen

if blue>255 then blue=oldblue

ink rgb(red,green,blue),rgb(0,0,0)

DBPolygon(x,y,radius,sides):sync

endwhile

get image 200,0,0,799,599,1

canSave=1

repeat:until mouseclick()=1

return

Function DBPolygon(x,y,r,sides)

for i = 1 to 361 step int(360/sides)

nx = x+sin(i)*r

ny = y+cos(i)*r

if i = 1 then bx = nx : by = ny

if i <> 1 then line nx,ny,oldx,oldy:line nx,ny,x,y

oldx = nx

oldy = ny

next i

rem Finish Off

line bx,by,nx,ny

`line bx,by,(i/360)*640,0

EndFunction

function color_image(img,red#,green#,blue#)

set current bitmap 0

hide all sprites

if image exist(img)=1

FOR a=1 to 1

if memblock exist(a)=1 then delete memblock a

NEXT a

make memblock from image 1,img

sw=memblock dword(1,0) : `width

sh=memblock dword(1,4) : `height

for a=0 to sh-1

for b=0 to sw-1

c=memblock dword(1,12+b*4+a*sw*4)

r#=rgbr(c)+red#

if r#>255 then r#=255

if r#<0 then r#=0

g#=rgbg(c)+green#

if g#>255 then g#=255

if g#<0 then g#=0

b#=rgbb(c)+blue#

if b#>255 then b#=255

if b#<0 then b#=0

color=RGB(r#,g#,b#)

write memblock dword 1,12+b*4+a*sw*4,color

next b

next a

make image from memblock img,1

delete memblock 1

endif

paste image 200,0,0,1

sync

`get image 200,0,0,799,599,1

canSave=1

hide all sprites

repeat

until mouseclick()=1

endfunction

function greyscale_image(img)

set current bitmap 0

hide all sprites

if image exist(img)=1

FOR a=1 to 1

if memblock exist(a)=1 then delete memblock a

NEXT a

make memblock from image 1,img

sw=memblock dword(1,0) : `width

sh=memblock dword(1,4) : `height

for a=0 to sh-1

for b=0 to sw-1

c=memblock dword(1,12+b*4+a*sw*4)

value=light_value(c)

color=rgb(value,value,value)

write memblock dword 1,12+b*4+a*sw*4,color

next b

next a

make image from memblock img,1

delete memblock 1

endif

paste image 200,0,0,1

sync

get image 200,0,0,799,599,1

canSave=1

hide all sprites

repeat

until mouseclick()=1

endfunction

FUNCTION light_value(rgb_value)

r=rgbr(rgb_value)

g=rgbg(rgb_value)

b=rgbb(rgb_value)

value#=(r+g+b)/3

ENDFUNCTION value#

testGetimage:

set current bitmap 0

hide all sprites

cls rgb(0,0,0)

paste image 200,0,0,1:sync

make memblock from image 1,200

`bytes 0 to 3 are the image width

`bytes 4 to 7 are the image height

`bytes 8 to 11 are the image depth

`bytes 12 throught to end are the image data grouped into

`     4 bytes per pixel the bytes are blue green and red

`     alpha channels

`the data is in double words which are blocks of 4 bytes

myWidth=memblock dword(1,0)

myHeight=memblock dword(1,4)

myDepth=memblock dword(1,8)

myBytes=mywidth*myHeight

for t=0 to myBytes-1

`lock pixels

`copy memory get pixels pointer() + t+4, get memblock ptr(1) + t+4, myBytes

`unlock pixels

sync

next t

`get image 200,0,0,799,599,1

canSave=1

repeat

until mouseclick()=1

return

function invert_image(img)

set current bitmap 0

hide all sprites

if image exist(img)=1

FOR a=1 to 1

if memblock exist(a)=1 then delete memblock a

NEXT a

make memblock from image 1,img

sw=memblock dword(1,0) : `width

sh=memblock dword(1,4) : `height

for a=0 to sh-1

for b=0 to sw-1

c=memblock dword(1,12+b*4+a*sw*4)

red#=rgbr(c):green#=rgbg(c):blue#=rgbb(c)

r#=255-red#:g#=255-green#:b#=255-blue#

color=RGB(r#,g#,b#)

write memblock dword 1,12+b*4+a*sw*4,color

next b

next a

make image from memblock img,1

delete memblock 1

endif

paste image 200,0,0,1

sync

`get image 200,0,0,799,599,1

canSave=1

hide all sprites

repeat

until mouseclick()=1

endfunction

function remove_colorchannel(img,col as integer)

set current bitmap 0

hide all sprites

if image exist(img)=1 and col>0 and col<4

FOR a=1 to 1

if memblock exist(a)=1 then delete memblock a

NEXT a

make memblock from image 1,img

sw=memblock dword(1,0) : `width

sh=memblock dword(1,4) : `height

for a=0 to sh-1

for b=0 to sw-1

c=memblock dword(1,12+b*4+a*sw*4)

red#=rgbr(c):green#=rgbg(c):blue#=rgbb(c)

r#=255-red#:g#=255-green#:b#=255-blue#

select col

case 1

r#=0

endcase

case 2

b#=0

endcase

case 3

g#=0

endcase

endselect

color=RGB(r#,g#,b#)

write memblock dword 1,12+b*4+a*sw*4,color

next b

next a

make image from memblock img,1

delete memblock 1

endif

paste image 200,0,0,1

sync

`get image 200,0,0,799,599,1

canSave=1

hide all sprites

repeat

until mouseclick()=1

endfunction

function brighten_darken(img,ammount as integer,flag as boolean)

set current bitmap 0

hide all sprites

if image exist(img)=1

FOR a=1 to 1

if memblock exist(a)=1 then delete memblock a

NEXT a

make memblock from image 1,img

sw=memblock dword(1,0) : `width

sh=memblock dword(1,4) : `height

for a=0 to sh-1

for b=0 to sw-1

c=memblock dword(1,12+b*4+a*sw*4)

red#=rgbr(c):green#=rgbg(c):blue#=rgbb(c)

if flag=1

r#=red#+ammount:if r#>255 then r#=255

g#=green#+ammount:if g#>255 then g#=255

b#=blue#+ammount:if b#>255 then b#=255

else

r#=red#-ammount:if r#<0 then r#=0

g#=green#-ammount:if g#<0 then g#=0

b#=blue#-ammount:if b#<0 then b#=0

endif

color=RGB(r#,g#,b#)

write memblock dword 1,12+b*4+a*sw*4,color

next b

next a

make image from memblock img,1

delete memblock 1

endif

paste image 200,0,0,1

sync

`get image 200,0,0,799,599,1

canSave=1

hide all sprites

repeat

until mouseclick()=1

endfunction

Download

Please login to download

Comments

No comments yet.

Author Name:	fubarpk
CodeBase Entries:	12

CodeBase - fubars workshop

Information

Summary

Full Description

DarkBASIC Professional Source Code

Download

Screen Shot

Author

Comments