(919)  Login

English
Source / code snippets

Bildbearbeitungsfilter Bitmaps

 

CompileMarkSeparation
'Source watts on the 15.07.2007 from the MMJ-Quellcodesammlung (Dietmar horn) into Babyklappe on XProfan.com stored:
'Bitmaps: Bildbearbeitungsfilter
'executable ex Profan-Version 5.0
'+----------------------------------------------------------+
'| presentment.prf                                                 |
'| Author: Sebastian king                                   |
'| email: koenig.hil@t-online.de                            |
'| Homepage: https://www.sekoenig.mysite.de                  |
'| some example To Bildbearbeitungsfiltern with Profan.   |
'| VORSICHT: Runs in the Interpreter extreme slow.           |
'+----------------------------------------------------------+
 $I filter.inc'----------------------------------------------------------------------------
'--Deklarationen
declare f1%,f2%,f3%,f4%
declare end%
declare File$
'--New Window
windowstyle 24
window 0,0-%maxX,%maxY
windowtitle "Einige Examples of Bildbearbeitungsfilter"
'SetTrueColor 1   <--is rather so
textcolor 0,-1
drawtext 0,0,"Bitte dial..."
let f1%=@create("button",%hwnd,"Graustufen",100,100,200,30)
let f2%=@create("button",%hwnd,"Halbton",100,140,200,30)
let f3%=@create("button",%hwnd,"Weichzeichnen",100,180,200,30)
let f4%=@create("button",%hwnd,"Stark Weichzeichnen",100,220,200,30)
let end%=1
chdir $winpath

while end%

    waitinput

    if  @getfocus(f1%)

        @destroywindow(f1%)
        @destroywindow(f2%)
        @destroywindow(f3%)
        @destroywindow(f4%)
        let File$=@LoadFile $("Datei open...","*.BMP")
        LoadBmp File$,0,0;0
        graustufen 0,0,%BmpX,%BmpY
        @messagebox("Fertig!","Meldung",0)
        end

    elseif @getfocus(f2%)

        @destroywindow(f1%)
        @destroywindow(f2%)
        @destroywindow(f3%)
        @destroywindow(f4%)
        let File$=@LoadFile $("Datei open...","*.BMP")' File select...
        LoadBmp File$,0,0;0'...loading...
        halbton 0,0,%BmpX,%BmpY'...and filter utilize
        @messagebox("Fertig!","Meldung",0)
        end

    elseif @getfocus(f3%)

        @destroywindow(f1%)
        @destroywindow(f2%)
        @destroywindow(f3%)
        @destroywindow(f4%)
        let File$=@LoadFile $("Datei open...","*.BMP")
        LoadBmp File$,0,0;0
        weichzeichnen 0,0,%BmpX,%BmpY
        @messagebox("Fertig!","Meldung",0)
        end

    elseif @getfocus(f4%)

        @destroywindow(f1%)
        @destroywindow(f2%)
        @destroywindow(f3%)
        @destroywindow(f4%)
        let File$=@LoadFile $("Datei open...","*.BMP")
        LoadBmp File$,0,0;0
        stark_weichzeichnen 0,0,%BmpX,%BmpY
        @messagebox("Fertig!","Meldung",0)
        end

    endif

wend

end

CompileMarkSeparation
' $I filter.inc  Include File with Filtern
'----------------------------------------------------------------------------
 $I profalt.inc

proc Graustufen

    parameters startx%,starty%,endx%,endy%
    declare x%,y%
    declare r%,g%,b%
    let x%=startx%
    let y%=starty%
    let endx%=@add(startx%,endx%)
    let endy%=@add(starty%,endy%)

    while @Lt(y%,endy%)

        while @Lt(x%,endx%)

            let r%=@div&(@add(@add(@GetRValue(@GetPixel(x%,y%)),@GetGValue(\
            @GetPixel(x%,y%))),@GetBValue(@GetPixel(x%,y%))),3)
            let g%=r%
            let b%=g%
            SetPixel x%,y%,@RGB(r%,g%,b%)
            inc x%

        wend

        let x%=startx%
        inc y%

    wend

endproc

proc Weichzeichnen

    parameters startx%,starty%,endx%,endy%
    declare x%,y%
    declare r%,g%,b%
    let x%=startx%
    let y%=starty%
    let endx%=@sub(@add(startx%,endx%),1)
    let endy%=@sub(@add(starty%,endy%),1)

    while @Lt(y%,endy%)

        while @Lt(x%,endx%)

            let r%=@div&(@add(@add(@GetRValue(@getPixel(x%,y%)),@GetRValue(@getPixel(@add(x%,1),y%))),\
            @GetRValue(@getPixel(x%,@add(y%,1)))),3)
            let g%=@div&(@add(@add(@GetGValue(@getPixel(x%,y%)),@GetGValue(@getPixel(@add(x%,1),y%))),\
            @GetGValue(@getPixel(x%,@add(y%,1)))),3)
            let b%=@div&(@add(@add(@GetBValue(@getPixel(x%,y%)),@GetBValue(@getPixel(@add(x%,1),y%))),\
            @GetBValue(@getPixel(x%,@add(y%,1)))),3)
            SetPixel x%,y%,@RGB(r%,g%,b%)
            inc x%

        wend

        let x%=startx%
        inc y%

    wend

endproc

proc Stark_Weichzeichnen

    parameters startx%,starty%,endx%,endy%
    declare x%,y%
    declare r%,g%,b%
    declare value1%,value2%,value3%,value4%,value5%
    let x%=@add(startx%,1)
    let y%=@add(starty%,1)
    let endx%=@sub(@add(startx%,endx%),1)
    let endy%=@sub(@add(starty%,endy%),1)

    while @Lt(y%,endy%)

        while @Lt(x%,endx%)

            let value1%=@getRValue(@GetPixel(x%,y%))
            let value2%=@getRValue(@GetPixel(@add(x%,1),y%))
            let value3%=@getRValue(@GetPixel(x%,@add(y%,1)))
            let value4%=@getRValue(@getPixel(@sub(x%,1),y%))
            let value5%=@getRValue(@getPixel(x%,@sub(y%,1)))
            let r%=@div&(@add(@add(@add(value1%,value2%),@add(value3%,value4%)),value5%),5)
            let value1%=@getGValue(@GetPixel(x%,y%))
            let value2%=@getGValue(@GetPixel(@add(x%,1),y%))
            let value3%=@getGValue(@GetPixel(x%,@add(y%,1)))
            let value4%=@getGValue(@getPixel(@sub(x%,1),y%))
            let value5%=@getGValue(@getPixel(x%,@sub(y%,1)))
            let g%=@div&(@add(@add(@add(value1%,value2%),@add(value3%,value4%)),value5%),5)
            let value1%=@getBValue(@GetPixel(x%,y%))
            let value2%=@getBValue(@GetPixel(@add(x%,1),y%))
            let value3%=@getBValue(@GetPixel(x%,@add(y%,1)))
            let value4%=@getBValue(@getPixel(@sub(x%,1),y%))
            let value5%=@getBValue(@getPixel(x%,@sub(y%,1)))
            let b%=@div&(@add(@add(@add(value1%,value2%),@add(value3%,value4%)),value5%),5)
            SetPixel x%,y%,@RGB(r%,g%,b%)
            inc x%

        wend

        let x%=startx%
        inc y%

    wend

endproc

proc Halbton

    parameters startx%,starty%,endx%,endy%
    declare x%,y%
    declare color%
    let x%=startx%
    let y%=starty%
    let endx%=@add(startx%,endx%)
    let endy%=@add(starty%,endy%)

    while @Lt(y%,endy%)

        while @Lt(x%,endx%)

            let color%=@div&(@add(@add(@GetRValue(@GetPixel(x%,y%)),@GetGValue(\
            @GetPixel(x%,y%))),@GetBValue(@GetPixel(x%,y%))),3)
            case @equ(color%,@div&(255,2)) : let color%=@RGB(255,255,255)
            case @Lt(color%,@div&(255,2))  : let color%=@RGB(0,0,0)
            case @Gt(color%,@div&(255,2))  : let color%=@RGB(255,255,255)
            SetPixel x%,y%,color%
            inc x%

        wend

        let x%=startx%
        inc y%

    wend

endproc
 
07/15/07  ▲
 




Jörg
Sellmeyer
filter.inc and Hauptprogramm abstracted.
the would still something, if the code to ASM portiert would...
CompileMarkSeparation
'Source watts on the 15.07.2007 from the MMJ-Quellcodesammlung (Dietmar horn) into Babyklappe on XProfan.com stored:
'Bitmaps: Bildbearbeitungsfilter
'executable ex Profan-Version 5.0
'+----------------------------------------------------------+
'| presentment.prf                                                 |
'| Author: Sebastian king                                   |
'| email: koenig.hil@t-online.de                            |
'| Homepage: https://www.sekoenig.mysite.de                  |
'| some example To Bildbearbeitungsfiltern with Profan.   |
'| VORSICHT: Runs in the Interpreter extreme slow.           |
'+----------------------------------------------------------+
' $I filter.inc  Include File with Filtern
'----------------------------------------------------------------------------
 $I profalt.inc

proc Graustufen

    parameters startx%,starty%,endx%,endy%
    declare x%,y%
    declare r%,g%,b%
    let x%=startx%
    let y%=starty%
    let endx%=@add(startx%,endx%)
    let endy%=@add(starty%,endy%)

    while @Lt(y%,endy%)

        while @Lt(x%,endx%)

            let r%=@div&(@add(@add(@GetRValue(@GetPixel(x%,y%)),@GetGValue(\
            @GetPixel(x%,y%))),@GetBValue(@GetPixel(x%,y%))),3)
            let g%=r%
            let b%=g%
            SetPixel x%,y%,@RGB(r%,g%,b%)
            inc x%

        wend

        let x%=startx%
        inc y%

    wend

endproc

proc Weichzeichnen

    parameters startx%,starty%,endx%,endy%
    declare x%,y%
    declare r%,g%,b%
    let x%=startx%
    let y%=starty%
    let endx%=@sub(@add(startx%,endx%),1)
    let endy%=@sub(@add(starty%,endy%),1)

    while @Lt(y%,endy%)

        while @Lt(x%,endx%)

            let r%=@div&(@add(@add(@GetRValue(@getPixel(x%,y%)),@GetRValue(@getPixel(@add(x%,1),y%))),\
            @GetRValue(@getPixel(x%,@add(y%,1)))),3)
            let g%=@div&(@add(@add(@GetGValue(@getPixel(x%,y%)),@GetGValue(@getPixel(@add(x%,1),y%))),\
            @GetGValue(@getPixel(x%,@add(y%,1)))),3)
            let b%=@div&(@add(@add(@GetBValue(@getPixel(x%,y%)),@GetBValue(@getPixel(@add(x%,1),y%))),\
            @GetBValue(@getPixel(x%,@add(y%,1)))),3)
            SetPixel x%,y%,@RGB(r%,g%,b%)
            inc x%

        wend

        let x%=startx%
        inc y%

    wend

endproc

proc Stark_Weichzeichnen

    parameters startx%,starty%,endx%,endy%
    declare x%,y%
    declare r%,g%,b%
    declare value1%,value2%,value3%,value4%,value5%
    let x%=@add(startx%,1)
    let y%=@add(starty%,1)
    let endx%=@sub(@add(startx%,endx%),1)
    let endy%=@sub(@add(starty%,endy%),1)

    while @Lt(y%,endy%)

        while @Lt(x%,endx%)

            let value1%=@getRValue(@GetPixel(x%,y%))
            let value2%=@getRValue(@GetPixel(@add(x%,1),y%))
            let value3%=@getRValue(@GetPixel(x%,@add(y%,1)))
            let value4%=@getRValue(@getPixel(@sub(x%,1),y%))
            let value5%=@getRValue(@getPixel(x%,@sub(y%,1)))
            let r%=@div&(@add(@add(@add(value1%,value2%),@add(value3%,value4%)),value5%),5)
            let value1%=@getGValue(@GetPixel(x%,y%))
            let value2%=@getGValue(@GetPixel(@add(x%,1),y%))
            let value3%=@getGValue(@GetPixel(x%,@add(y%,1)))
            let value4%=@getGValue(@getPixel(@sub(x%,1),y%))
            let value5%=@getGValue(@getPixel(x%,@sub(y%,1)))
            let g%=@div&(@add(@add(@add(value1%,value2%),@add(value3%,value4%)),value5%),5)
            let value1%=@getBValue(@GetPixel(x%,y%))
            let value2%=@getBValue(@GetPixel(@add(x%,1),y%))
            let value3%=@getBValue(@GetPixel(x%,@add(y%,1)))
            let value4%=@getBValue(@getPixel(@sub(x%,1),y%))
            let value5%=@getBValue(@getPixel(x%,@sub(y%,1)))
            let b%=@div&(@add(@add(@add(value1%,value2%),@add(value3%,value4%)),value5%),5)
            SetPixel x%,y%,@RGB(r%,g%,b%)
            inc x%

        wend

        let x%=startx%
        inc y%

    wend

endproc

proc Halbton

    parameters startx%,starty%,endx%,endy%
    declare x%,y%
    declare color%
    let x%=startx%
    let y%=starty%
    let endx%=@add(startx%,endx%)
    let endy%=@add(starty%,endy%)

    while @Lt(y%,endy%)

        while @Lt(x%,endx%)

            let color%=@div&(@add(@add(@GetRValue(@GetPixel(x%,y%)),@GetGValue(\
            @GetPixel(x%,y%))),@GetBValue(@GetPixel(x%,y%))),3)
            case @equ(color%,@div&(255,2)) : let color%=@RGB(255,255,255)
            case @Lt(color%,@div&(255,2))  : let color%=@RGB(0,0,0)
            case @Gt(color%,@div&(255,2))  : let color%=@RGB(255,255,255)
            SetPixel x%,y%,color%
            inc x%

        wend

        let x%=startx%
        inc y%

    wend

endproc

'filter.inc end
'----------------------------------------------------------------------------
'--Deklarationen
declare f1%,f2%,f3%,f4%
declare end%
declare File$
'--New Window
windowstyle 24
window 0,0-%maxX,%maxY
windowtitle "Einige Examples of Bildbearbeitungsfilter"
'SetTrueColor 1   <--is rather so
textcolor 0,-1
drawtext 0,0,"Bitte dial..."
let f1%=@create("button",%hwnd,"Graustufen",100,100,200,30)
let f2%=@create("button",%hwnd,"Halbton",100,140,200,30)
let f3%=@create("button",%hwnd,"Weichzeichnen",100,180,200,30)
let f4%=@create("button",%hwnd,"Stark Weichzeichnen",100,220,200,30)
let end%=1
chdir $winpath

while end%

    waitinput

    if  @getfocus(f1%)

        @destroywindow(f1%)
        @destroywindow(f2%)
        @destroywindow(f3%)
        @destroywindow(f4%)
        let File$=@LoadFile $("Datei open...","*.BMP")
        LoadBmp File$,0,0;0
        graustufen 0,0,%BmpX,%BmpY
        @messagebox("Fertig!","Meldung",0)
        end

    elseif @getfocus(f2%)

        @destroywindow(f1%)
        @destroywindow(f2%)
        @destroywindow(f3%)
        @destroywindow(f4%)
        let File$=@LoadFile $("Datei open...","*.BMP")' File select...
        LoadBmp File$,0,0;0'...loading...
        halbton 0,0,%BmpX,%BmpY'...and filter utilize
        @messagebox("Fertig!","Meldung",0)
        end

    elseif @getfocus(f3%)

        @destroywindow(f1%)
        @destroywindow(f2%)
        @destroywindow(f3%)
        @destroywindow(f4%)
        let File$=@LoadFile $("Datei open...","*.BMP")
        LoadBmp File$,0,0;0
        weichzeichnen 0,0,%BmpX,%BmpY
        @messagebox("Fertig!","Meldung",0)
        end

    elseif @getfocus(f4%)

        @destroywindow(f1%)
        @destroywindow(f2%)
        @destroywindow(f3%)
        @destroywindow(f4%)
        let File$=@LoadFile $("Datei open...","*.BMP")
        LoadBmp File$,0,0;0
        stark_weichzeichnen 0,0,%BmpX,%BmpY
        @messagebox("Fertig!","Meldung",0)
        end

    endif

wend

end
 
Windows XP SP2 XProfan X4
... und hier mal was ganz anderes als Profan ...
06/23/18  ▲
 



Zum Quelltext


Topictitle, max. 100 characters.
 

Systemprofile:

no Systemprofil laid out. [anlegen]

XProfan:

 Posting  Font  Smilies  ▼ 

Please register circa a Posting To verfassen.
 

Topic-Options

Unreaded
subscribe
Remember-List
Notes
guests
Delete
Permanent
Done

3.612 Views

Untitledvor 0 min.
Stringray01/05/22
Rolf Koch09/06/20
Georg Teles08/26/19
Pedro Miguel05/17/19
More...

Themeninformationen

this Topic has 2 subscriber:

Jörg Sellmeyer (1x)
unbekannt (1x)


Admins  |  AGB  |  Applications  |  Authors  |  Chat  |  Privacy Policy  |  Download  |  Entrance  |  Help  |  Merchantportal  |  Imprint  |  Mart  |  Interfaces  |  SDK  |  Services  |  Games  |  Search  |  Support

One proposition all XProfan, The there's!


My XProfan
Private Messages
Own Storage Forum
Topics-Remember-List
Own Posts
Own Topics
Clipboard
Log off
 Deutsch English Français Español Italia
Translations

Privacy Policy


we use Cookies only as Session-Cookies because of the technical necessity and with us there no Cookies of Drittanbietern.

If you here on our Website click or navigate, stimmst You ours registration of Information in our Cookies on XProfan.Net To.

further Information To our Cookies and moreover, How You The control above keep, find You in ours nachfolgenden Datenschutzerklärung.

all rightDatenschutzerklärung
i want none Cookie