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

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.

                                    ` 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
   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
   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
   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