'Erstellen eines Kontur images by Bob

Superstrict
Graphics 800,600
SetClsColor 128,128,128
Cls


'Unser Bild das mit einer Kontur versehen werden soll
Local img:TImage =LoadImage("einheiten.png")
'Das Konturbild
Local Outline_img:TImage =outlineImg(img,$ffff00ff)
'Beide Bilder ubereinandermalen


While not KeyHit(KEY_ESCAPE)
   'Anzeigen Orginal
   DrawImage img,0,0

   'Anzeigen Outline Bild
   iF    MouseX()<= ImageWidth(img) and MouseY()<=ImageHeight(img) and MouseX()>0 and MouseY()>0 then
      
      DrawImage outline_img,0,0
   endif
   Flip
   Cls
Wend
End

Function outlineImg:TImage(img:TImage, s_col:int = $FFFFFFFF)
   's_col = Suchfarbe per default weiss  mit 255 Alpha = volle deckung
   
   'Hilfsarrays mit Richtungsangaben
   'kann auch Global, ausserhalb der Function declariert werden
   local DirX:Int[8]
   Local DirY:Int[8]
   
   DirX[0] = 0      'N
   DirX[1] = 1      'O
   DirX[2] = 0      'S
   DirX[3] = -1   'W
   DirX[4] = 1      'NO
   DirX[5] = 1      'SO
   DirX[6] = -1   'SW
   DirX[7] = -1   'NW
   
   DirY[0] = -1   'N
   DirY[1] = 0      'O
   DirY[2] = 1      'S
   DirY[3] = 0      'W
   DirY[4] = -1   'NO
   DirY[5] = 1      'SO
   DirY[6] = 1      'SW
   DirY[7] = -1   'NW
   
   

   'Bilddimension ermitteln
   Local wID:Int=ImageWidth(img)
      Local hEi:Int=ImageHeight(img)
      'Neues leeres Bild erstellen das das outline bild aufnehmen wird
   Local newimg:TImage = CreateImage(wID, hei)
   
   'Lokales Array mit allen Pixeln des orginal Bildes
   Local col:int[,] = New Int [wID,hei]
   
   'Orginalbild In Pixmap überführen und sperren
   Local oldimage:TPixmap = LockImage(img)
   
      
   Local x:Int
   Local y:Int
   
   'Farbarray des Orginals erstellen
   For  x =0 To wID-1
      For y =0 To hei-1
          col[x,y]=ReadPixel(oldimage,x,y)
      Next
   Next
   
   'Sperrung aufheben
   UnlockImage(img)
   
   'Outline bild Sperren
   Local PXM:TPixmap = LockImage(newimg)
   
   'Hilfsvariablen
   Local NX:Int
   Local Ny:int
   local argb:int
   'Doppelschleife über gesamte Bild Dimensionen
   For x=0 To wID-1
      For y=0 To hei-1
          
         'Perdefault Schreibfarbe auf belibigen wert mir 0 Alpha Anteil setzen. Sprich:Transparent
         argb= $00ffffff

         'Wenn aktuelle Farbe anders als suchfarbe
         if col[x,y]<>s_col then
            'Alle Richtungen auf Rand oder Suchfarbe Prüfen
            For Local R:Int = 0 to 7
               NX = x + dirx[r]
               NY = y + DirY[r]
               'Auf jeden Fall Pixel setzen wenn aktuelle x,y position am Rand ist
               'bzw NX und NY nicht mehr im Farbarray sind
               if nx<0 or ny<0 or NX>wID-1 or ny >hei-1 then
                  'Schwarz mit voller Alpha Deckung
                  argb = $ff000000
                  exit
               else 'Andernfalls Prüfen ob aktuelle Position <> weiss ist
                  if col[nx,ny]= s_col then
                     'Schwarz mit voller Alpha Deckung
                     argb = $ff000000
                     exit
                  endif
               End If
            
            Next
            WritePixel pxm, x,y, argb
         End If
      Next
   Next

   UnlockImage(newimg)   
      Return newimg
End Function

SuperStrict

Framework BRL.Max2D
Import BRL.GLMax2D
Import BRL.PNGLoader
Import BRL.Retro

SetGraphicsDriver GLMax2DDriver()
Graphics 640 , 480 , 0 , 60
SetClsColor 100 , 140 , 60
SetMaskColor 100 , 140 , 60
SetBlend ALPHABLEND

Cls ; DrawText "Bild wird aus dem Internetz heruntergeladen..." , 0 , 0 ; Flip
Local download:TBank = LoadBank("http::horstderbiber.ho.funpic.de/kram/bmpfont.png")
Local img:TImage = LoadImage(download)
If img = Null Then RuntimeError("Bild konnte nicht geladen werden :C")

Cls ; DrawText "Kontur wird gemalt..." , 0 , 0 ; Flip
SetAlpha 0.2
Local outlineimg:TImage = CreateOutlineImage(img , 2)
SetAlpha 0.1
outlineimg:TImage = CreateOutlineImage(outlineimg , 1)
SetColor 255 , 255 , 255
SetAlpha 1

Repeat
   Cls
   If MouseX() <= img.width And MouseY() <= img.height And MouseX() > 0 And MouseY() > 0 Then
      DrawImage outlineimg , 0 , 0
   Else
      DrawImage img , 0 , 0
   EndIf
   Flip
Until AppTerminate() Or KeyHit(KEY_ESCAPE)
End

Function CreateOutlineImage:TImage(srcimg:TImage , radius:Int)
   Local outimg:TImage , readpix:TPixmap , outpix:TPixmap
   Local offsetx:Int = srcimg.width , offsety:Int = srcimg.height , offsetw:Int = srcimg.width , offseth:Int = srcimg.height
   Local x:Int , y:Int , i:Int , j:Int , k:Int , l:Int , a:Int , r:Int , g:Int , b:Int , solidneighbors:Int
   Local perimeter:Float , rotstep:Float

   If radius < 1 Then Return srcimg

   readpix = LockImage(srcimg)

   'bild wenn erforderlich vergrößern
   For i = 0 To readpix.width - 1
      For j = 0 To readpix.height - 1
         argbfromint(ReadPixel(readpix , i , j) , a , r , g , b)
         If PixelIsSolid(a , r , g , b) Then
            If offsetx > i Then offsetx = i
            If offsety > j Then offsety = j
            If offsetw > readpix.width - 1 - i Then offsetw = readpix.width - 1 - i
            If offseth > readpix.height - 1 - j Then offseth = readpix.height - 1 - j
         EndIf
      Next
   Next
   offsetx = radius - offsetx
   offsety = radius - offsety
   offsetw = radius - offsetw
   offseth = radius - offseth
   If offsetx < 0 Then offsetx = 0
   If offsety < 0 Then offsety = 0
   If offsetw < 0 Then offsetw = 0
   If offseth < 0 Then offseth = 0

   'kopieren
   outpix = CreatePixmap(readpix.width + offsetx + offsetw , readpix.height + offsety + offseth , readpix.format)
   For i = 0 To outpix.width - 1
      For j = 0 To outpix.height - 1
         If i >= offsetx And j >= offsety And i <= outpix.width - 1 - offsetw And j <= outpix.height - 1 - offseth Then
            WritePixel outpix , i , j , ReadPixel(readpix , i - offsetx , j - offsety)
         Else
            GetMaskColor r , g , b
            WritePixel outpix , i , j , ARGBToInt(0 , r , g , b)
         EndIf
      Next
   Next
   readpix = CopyPixmap(outpix)

   'kontur malen
   For i = 0 To readpix.width - 1
      For j = 0 To readpix.height - 1
         argbfromint(ReadPixel(readpix , i , j) , a , r , g , b)
         If Not PixelisSolid(a , r , g , b) Then
            solidneighbors = 0
            If i > 0 Then
               argbfromint(ReadPixel(readpix , i - 1 , j) , a , r , g , b)
               If PixelIsSolid(a , r , g , b) Then solidneighbors:+ 1
            EndIf
            If j > 0 Then
               argbfromint(ReadPixel(readpix , i , j - 1) , a , r , g , b)
               If PixelIsSolid(a , r , g , b) Then solidneighbors:+ 1
            EndIf
            If i < readpix.width - 1 Then
               argbfromint(ReadPixel(readpix , i + 1 , j) , a , r , g , b)
               If PixelIsSolid(a , r , g , b) Then solidneighbors:+ 1
            EndIf
            If j < readpix.height - 1 Then
               argbfromint(ReadPixel(readpix , i , j + 1) , a , r , g , b)
               If PixelIsSolid(a , r , g , b) Then solidneighbors:+ 1
            EndIf

            If solidneighbors > 0 Then
               GetColor(r , g , b)
               WritePixel outpix , i , j , ARGBToInt(GetAlpha() * 255.0 , r , g , b)
               If radius > 1 Then
                  For k = 1 To radius-1
                     perimeter = 2 * k * Pi
                     rotstep = 360.0 / perimeter
                     For l = 0 To Ceil(perimeter)
                        x = FloatToInt(i + Sin(l * rotstep) * k)
                        y = FloatToInt(j - Cos(l * rotstep) * k)

                        ARGBFromInt(ReadPixel(outpix , x , y) , a , r , g , b)
                        If Not PixelIsSolid(a , r , g , b) Then
                           GetColor r , g , b
                           WritePixel outpix , x , y , ARGBToInt(GetAlpha() * 255.0 , r , g , b)
                        EndIf
                     Next
                  Next
               EndIf
            EndIf
         EndIf
      Next
   Next

   UnlockImage srcimg
   outimg = LoadImage(outpix)
   Return outimg
End Function

Function PixelIsSolid:Byte(a:Int , r:Int , g:Int , b:Int)
   Local mr:Int , mg:Int , mb:Int

   Select GetBlend()
   Case ALPHABLEND
      If a = 0 Then Return False
   Default
      If a < 128 Then Return False
   End Select

   GetMaskColor mr , mg , mb
   If r = mr And g = mg And b = mb Then Return False
   Return True
End Function

Function ARGBFromInt(argb:Int , alpha:Int Var , red:Int Var , green:Int Var , blue:Int Var)
   alpha = (argb Shr 24) & $FF
   red = (argb Shr 16) & $FF
   green = (argb Shr 8) & $FF
   blue = argb & $FF
End Function

Function ARGBToInt:Int(alpha:Int , red:Int , green:Int , blue:Int)
   Return (alpha Shl 24) | (red Shl 16) | (green Shl 8) | blue
End Function

Function FloatToInt:Int(val:Float)
   If val - Int(val) < 0.5 Then
      Return Int(Floor(val))
   Else
      Return Int(Ceil(val))
   EndIf
End Function