Board Logo
« Comet Tracking Fun »

Welcome Guest. Please Login or Register.
Jan 21st, 2018, 12:50am


Conforums Terms of Service | Membership Rules | Home | Search | Recent Posts | Notification | Format Your Message | Installation FAQ

Please use the forums Search feature before asking.
Please post code using the code box described in Format Your Messages.
This will keep indentation, separate it better form the message and prevent gibberish.
If the code is too long for one post or additional files are needed, upload a ZIP archive to the Just BASIC Files Archive Site.

« Previous Topic | Next Topic »
Pages: 1 2 3  Notify Send Topic Print
 veryhotthread  Author  Topic: Comet Tracking Fun  (Read 359 times)
Rod
Administrator
ImageImageImageImageImage


member is offline

Avatar

Graphics = Goosebumps!


PM

Gender: Male
Posts: 3151
xx Comet Tracking Fun
« Thread started on: Jun 8th, 2012, 07:07am »

Ok for anyone interested in graphics and astronomy this should be fun.

The code below will draw you a set of ten bitmaps that mimic a telescope's eye view of the night sky. A comet passes, your job is to find the comet programatically.

First working post wins but no time line, because I think we should see how a variety of folks would tackle the job.

This is a merged image of a few of the bitmaps, you will see the comet in the top left of the image, it moves in a different direction to the stars.

Now I know planets do too but we are keeping it simple!

User Image


This code will save ten bitmap images in the folder you place it in.

Code:
nomainwin
' find how much whitespace the windows scheme is taking
' Anatoly's tip
WindowWidth = 200
WindowHeight = 200
open "Ajusting..." for graphics_nf_nsb as #temp
#temp, "home ; down ; posxy w h"
w=200-2*w : h = 200-2*h
close #temp

' setup a  400 x 400 graphics view
WindowWidth  = 400+w
WindowHeight = 400+h
UpperLeftX   = (DisplayWidth-WindowWidth)/2
UpperLeftY   = (DisplayHeight-WindowHeight)/2
open "Starfield" for graphics_nf_nsb as #g
#g "trapclose [quit]"

'visible drawing coordinates are 0 to 400 ie 401 pixels
'200 200 becomes the exact centre of the view
'#g "down ; place 0 0; color red ; box 400 400"
'#g "place 200 200 ; circle 200 "
'wait

cometX=100
cometY=100
cometD=4
maxstar=100
dim star(maxstar,4)
Xindex=1
Yindex=2
Bright=3
Colors=4
for n=1 to maxstar
    star(n,Xindex)=int(rnd(0)*400)
    star(n,Yindex)=int(rnd(0)*400)
    star(n,Bright)=int(rnd(0)*3+1)
    star(n,Colors)=int(rnd(0)*128+128)
next



#g "down"
for x=0 to WindowWidth
    for y=0 to WindowHeight
    c=int(rnd(0)*30+1)
        #g "color ";c;" ";c;" ";c
        #g "set ";x;" ";y
    next
next
#g "flush background"
Xoffset=0
Yoffset=0
for image=1 to 10
    #g "discard ; redraw background"
    #g "size 4 ; color white ; set ";cometX;" ";cometY
    cometX=cometX+cometD
    cometY=cometY-cometD
    for n=1 to maxstar
        #g "size ";star(n,Bright)
        #g "color ";star(n,Colors);" ";star(n,Colors);" ";star(n,Colors)
        #g "set ";star(n,Xindex)+Xoffset;" ";star(n,Yindex)+Yoffset
    next
    Xoffset=Xoffset+1
    Yoffset=Yoffset+1
    #g "getbmp bmp";str$(image);" 0 0 400 400"
    bmpsave "bmp";str$(image) , "bmp";str$(image);".bmp"
next
wait

[quit]
close #g
end
 
User IP Logged

Rod
Administrator
ImageImageImageImageImage


member is offline

Avatar

Graphics = Goosebumps!


PM

Gender: Male
Posts: 3151
xx Re: Comet Tracking Fun
« Reply #1 on: Jun 9th, 2012, 03:12am »

There are examples on the board of how to open a .bmp directly and process the color values for each pixel. Rutger shows us one example here.
http://justbasic.conforums.com/index.cgi?board=novice&action=display&num=1285642984&start=
User IP Logged

Rod
Administrator
ImageImageImageImageImage


member is offline

Avatar

Graphics = Goosebumps!


PM

Gender: Male
Posts: 3151
xx Re: Comet Tracking Fun
« Reply #2 on: Jun 10th, 2012, 09:09am »

Just in case folks are getting hung up on loading bmp data I append some code. Just BASIC will save .bmps in the resolution that your screen is set to. So my previous code will write 32bit or 24bit bmp files.

There is also a little quirk in Just BASIC where the first three colors are reserved by the system so the standard 54 byte offset may not apply. The code reads the offset from the file.

Also it is standard practice in a bmp file to ensure each line stops on a four byte boundary. So for 24bit bmps the file might be padded with a few bytes to ensure each line is a multiple of exactly 4 bytes. 32bit images are multiples of four anyway so no padding required for 32bit images.

See, your having fun already!

Code:
 'nomainwin



    fileName$="c:\atemp\bmp1.bmp"
    Open fileName$ For Binary As #bmp
        'get the length of the file
        lenFile = lof(#bmp)

        'get bmp info
        info$ = input$(#bmp,54)

        'extract bmp info
        bmpWidth = value(mid$(info$,19,2))'width in pixels of image
        bmpHeight = value(mid$(info$,23,2))'height in pixels of image
        bmpOffset = value(mid$(info$,11,4))'offset in file to pixel data 54 or 66 for Liberty bmps
        bmpColDepth = value(mid$(info$,29,2))/8 'color depth, 32bit/4bytes or 24bit/3bytes

        'work out padding, a raster must end on a 4 byte boundary
        rasterWidth=bmpWidth * bmpColDepth
        p=rasterWidth mod 4
        if p=3 then rasterWidth=rasterWidth+1
        if p=2 then rasterWidth=rasterWidth+2
        if p=1 then rasterWidth=rasterWidth+3

        print "Width ";bmpWidth
        print "Height ";bmpHeight
        print "Offset ";bmpOffset
        print "Color Depth ";bmpColDepth
        print "No bytes in raster ";rasterWidth

        'set pointer to first of color quad or triplet info
        seek #bmp,bmpOffset

        'load pixel data
        pixel$=input$(#bmp,lenFile-bmpOffset)
        pos=1
        for pixel=1 to 12
            print "color ",str$(pixel);",";
            print asc(mid$(pixel$,pos,1));",";
            print asc(mid$(pixel$,pos+1,1));",";
            if bmpColDepth>3 then
                print asc(mid$(pixel$,pos+2,1));",";
                print asc(mid$(pixel$,pos+3,1))
            else
                print asc(mid$(pixel$,pos+2,1))
            end if
            pos=pos+bmpColDepth
        next pixel
        close #bmp





    Wait

[quit]
close #g
end



function value(x$)
    select case len(x$)
        case 1
        value = asc(x$)
        case 2
        value=asc(mid$(x$,1,1))
        value=value+(asc(mid$(x$,2,1))*256)
        case 4
        value=asc(mid$(x$,1,1))
        value=value+(asc(mid$(x$,2,1))*256)
        value=value+(asc(mid$(x$,3,1))*65536)
        value=value+(asc(mid$(x$,4,1))*16777216)
    end select
end function


 
« Last Edit: Jun 17th, 2012, 1:40pm by Rod » User IP Logged

NJames
Senior Member
ImageImageImageImageImage


member is offline

Avatar




PM


Posts: 661
xx Re: Comet Tracking Fun
« Reply #3 on: Jun 11th, 2012, 07:06am »

What I have so far redraws the bitmap a pixel at a time, based on the information contained in pixel$. But, I see that the image drawn this way is rotated clockwise 90 degrees from what is displayed by simply using drawbmp. What am I doing wrong here?

Code:
 'nomainwin



    fileName$="bmp1.bmp"
    Open fileName$ For Binary As #bmp
        'get the length of the file
        lenFile = lof(#bmp)

        'get bmp info
        info$ = input$(#bmp,54)

        'extract bmp info
        bmpWidth = value(mid$(info$,19,2))'width in pixels of image
        bmpHeight = value(mid$(info$,23,2))'height in pixels of image
        bmpOffset = value(mid$(info$,11,4))'offset in file to pixel data 54 or 66 for Liberty bmps
        bmpColDepth = value(mid$(info$,29,2))/8 'color depth, 32bit/4bytes or 24bit/3bytes

        'work out padding, a raster must end on a 4 byte boundary
        rasterWidth=bmpWidth * bmpColDepth
        p=rasterWidth mod 4
        if p=3 then rasterWidth=rasterWidth+1
        if p=2 then rasterWidth=rasterWidth+2
        if p=1 then rasterWidth=rasterWidth+3

        print "Width ";bmpWidth
        print "Height ";bmpHeight
        print "Offset ";bmpOffset
        print "Color Depth ";bmpColDepth
        print "No bytes in raster ";rasterWidth

        'set pointer to first of color quad or triplet info
        seek #bmp,bmpOffset

        'load pixel data
        pixel$=input$(#bmp,lenFile-bmpOffset)
        pos=1
        for pixel=1 to 12
            print "color ",str$(pixel);",";
            print asc(mid$(pixel$,pos,1));",";
            print asc(mid$(pixel$,pos+1,1));",";
            if bmpColDepth>3 then
                print asc(mid$(pixel$,pos+2,1));",";
                print asc(mid$(pixel$,pos+3,1))
            else
                print asc(mid$(pixel$,pos+2,1))
            end if
            pos=pos+bmpColDepth
        next pixel
        close #bmp

        WindowWidth=bmpWidth*2+20
        WindowHeight=bmpHeight+100
        open "test" for graphics as #g
        #g "trapclose [QUIT]"
        #g "down"
        pos=1
        for x = 1 to bmpWidth
            for y = 1 to bmpHeight
                red=asc(mid$(pixel$,pos,1))
                green=asc(mid$(pixel$,pos+1,1))
                if bmpColDepth>3 then
                    blue=asc(mid$(pixel$,pos+2,1))
                    'print asc(mid$(pixel$,pos+3,1))
                    pos=pos+4
                else
                    blue=asc(mid$(pixel$,pos+2,1))
                    pos=pos+3
                end if
                #g "color ";red;" ";green;" ";blue
                #g "set ";x+10;" ";y+10
            next y
            scan
        next x

        loadbmp "bmp1", fileName$
        #g "drawbmp bmp1 ";bmpWidth+20;" 10"

    Wait

[QUIT]
close #g
unloadbmp "bmp1"
end



function value(x$)
    select case len(x$)
        case 1
        value = asc(x$)
        case 2
        value=asc(mid$(x$,1,1))
        value=value+(asc(mid$(x$,2,1))*256)
        case 4
        value=asc(mid$(x$,1,1))
        value=value+(asc(mid$(x$,2,1))*256)
        value=value+(asc(mid$(x$,3,1))*65536)
        value=value+(asc(mid$(x$,4,1))*16777216)
    end select
end function
 
« Last Edit: Jun 17th, 2012, 1:41pm by Rod » User IP Logged

Rod
Administrator
ImageImageImageImageImage


member is offline

Avatar

Graphics = Goosebumps!


PM

Gender: Male
Posts: 3151
xx Re: Comet Tracking Fun
« Reply #4 on: Jun 11th, 2012, 10:10am »

The image is stored a line at a time but the lines are in reverse order. So the bottom line is found first and the top line last. The lines run in normal order ie the first byte in a line is the first color value of the left most pixel of the line.

Small point, but some files will be padded, a 400 width file wont ever be because it produces a line which is multiple of four. So we get away with using bmpWidth but if the bmp width is not a multiple of four and is a 24bit image then there may be some padding at the end of each line, rasterWidth would tell you how much.

In terms of the challenge we can probably ignore that possibility.


Code:
'nomainwin



    fileName$="bmp1.bmp"
    Open fileName$ For Binary As #bmp
        'get the length of the file
        lenFile = lof(#bmp)

        'get bmp info
        info$ = input$(#bmp,54)

        'extract bmp info
        bmpWidth = value(mid$(info$,19,2))'width in pixels of image
        bmpHeight = value(mid$(info$,23,2))'height in pixels of image
        bmpOffset = value(mid$(info$,11,4))'offset in file to pixel data 54 or 66 for Liberty bmps
        bmpColDepth = value(mid$(info$,29,2))/8 'color depth, 32bit/4bytes or 24bit/3bytes

        'work out padding, a raster must end on a 4 byte boundary
        rasterWidth=bmpWidth * bmpColDepth
        p=rasterWidth mod 4
        if p=3 then rasterWidth=rasterWidth+1
        if p=2 then rasterWidth=rasterWidth+2
        if p=1 then rasterWidth=rasterWidth+3

        print "Width ";bmpWidth
        print "Height ";bmpHeight
        print "Offset ";bmpOffset
        print "Color Depth ";bmpColDepth
        print "No bytes in raster ";rasterWidth

        'set pointer to first of color quad or triplet info
        seek #bmp,bmpOffset

        'load pixel data
        pixel$=input$(#bmp,lenFile-bmpOffset)
        pos=1
        for pixel=1 to 12
            print "color ",str$(pixel);",";
            print asc(mid$(pixel$,pos,1));",";
            print asc(mid$(pixel$,pos+1,1));",";
            if bmpColDepth>3 then
                print asc(mid$(pixel$,pos+2,1));",";
                print asc(mid$(pixel$,pos+3,1))
            else
                print asc(mid$(pixel$,pos+2,1))
            end if
            pos=pos+bmpColDepth
        next pixel
        close #bmp

        WindowWidth=bmpWidth*2+40
        WindowHeight=bmpHeight+100
        open "test" for graphics as #g
        #g "trapclose [QUIT]"
        #g "down"
        pos=1
        for y = bmpHeight to 1 step -1
            for x = 1 to bmpWidth
                red=asc(mid$(pixel$,pos,1))
                green=asc(mid$(pixel$,pos+1,1))
                if bmpColDepth>3 then
                    blue=asc(mid$(pixel$,pos+2,1))
                    'print asc(mid$(pixel$,pos+3,1))
                    pos=pos+4
                else
                    blue=asc(mid$(pixel$,pos+2,1))
                    pos=pos+3
                end if
                #g "color ";red;" ";green;" ";blue
                #g "set ";x+10;" ";y+10
            next x
            scan
        next y

        loadbmp "bmp1", fileName$
        #g "drawbmp bmp1 ";bmpWidth+20;" 10"

    Wait

[QUIT]
close #g
unloadbmp "bmp1"
end



function value(x$)
    select case len(x$)
        case 1
        value = asc(x$)
        case 2
        value=asc(mid$(x$,1,1))
        value=value+(asc(mid$(x$,2,1))*256)
        case 4
        value=asc(mid$(x$,1,1))
        value=value+(asc(mid$(x$,2,1))*256)
        value=value+(asc(mid$(x$,3,1))*65536)
        value=value+(asc(mid$(x$,4,1))*16777216)
    end select
end function


 
« Last Edit: Jun 17th, 2012, 1:41pm by Rod » User IP Logged

NJames
Senior Member
ImageImageImageImageImage


member is offline

Avatar




PM


Posts: 661
xx Re: Comet Tracking Fun
« Reply #5 on: Jun 12th, 2012, 08:25am »

I tried to identify the direction of movement for each bright object in the sky, but neglected to notice that the comet is moving more than 1 pixel between frames. That quality (faster speed) could be used to locate the comet, in this test case, but that's not really the challenge is it?

Code:
        'nomainwin
        WindowWidth=440
        WindowHeight=440
        open "test" for graphics as #g
        #g "trapclose [QUIT]"
        #g "down ; fill black"

    dim bright(400,400)
    dim oldBright(400,400)
    dim from(400,400)


    ' 7 8 1
    ' 6 . 2
    ' 5 4 3
    dim dirX(8)
    dim dirY(8)
    dirX(1)=1  : dirY(1)=-1
    dirX(2)=1  : dirY(2)=0
    dirX(3)=1  : dirY(3)=1
    dirX(4)=0  : dirY(4)=1
    dirX(5)=-1 : dirY(5)=1
    dirX(6)=-1 : dirY(6)=0
    dirX(7)=-1 : dirY(7)=-1
    dirX(8)=0  : dirY(8)=-1

for whichBmp = 1 to 10
    redim bright(400,400)
    fileName$="bmp";whichBmp;".bmp"
    Open fileName$ For Binary As #bmp
        'get the length of the file
        lenFile = lof(#bmp)

        'get bmp info
        info$ = input$(#bmp,54)

        'extract bmp info
        bmpWidth = value(mid$(info$,19,2))'width in pixels of image
        bmpHeight = value(mid$(info$,23,2))'height in pixels of image
        bmpOffset = value(mid$(info$,11,4))'offset in file to pixel data 54 or 66 for Liberty bmps
        bmpColDepth = value(mid$(info$,29,2))/8 'color depth, 32bit/4bytes or 24bit/3bytes

        'work out padding, a raster must end on a 4 byte boundary
        rasterWidth=bmpWidth * bmpColDepth
        p=rasterWidth mod 4
        if p=3 then rasterWidth=rasterWidth+1
        if p=2 then rasterWidth=rasterWidth+2
        if p=1 then rasterWidth=rasterWidth+3

        print
        print fileName$
        print "Width ";bmpWidth
        print "Height ";bmpHeight
        print "Offset ";bmpOffset
        print "Color Depth ";bmpColDepth
        print "No bytes in raster ";rasterWidth

        'set pointer to first of color quad or triplet info
        seek #bmp,bmpOffset

        'load pixel data
        pixel$=input$(#bmp,lenFile-bmpOffset)
        pos=1
        for pixel=1 to 12
            print "color ",str$(pixel);",";
            print asc(mid$(pixel$,pos,1));",";
            print asc(mid$(pixel$,pos+1,1));",";
            if bmpColDepth>3 then
                print asc(mid$(pixel$,pos+2,1));",";
                print asc(mid$(pixel$,pos+3,1))
            else
                print asc(mid$(pixel$,pos+2,1))
            end if
            pos=pos+bmpColDepth
        next pixel
        close #bmp


        pos=1
        for y = bmpHeight to 1 step -1
            for x = 1 to bmpWidth
                red=asc(mid$(pixel$,pos,1))
                green=asc(mid$(pixel$,pos+1,1))
                if bmpColDepth>3 then
                    blue=asc(mid$(pixel$,pos+2,1))
                    'print asc(mid$(pixel$,pos+3,1))
                    pos=pos+4
                else
                    blue=asc(mid$(pixel$,pos+2,1))
                    pos=pos+3
                end if
                if red+green+blue>100 then
                    #g "color ";red;" ";green;" ";blue
                    #g "set ";x+10;" ";y+10
                    bright(x,y)=1
                    if oldBright(x,y)=0 then
                        foundAdjacent=0
                        for d = 1 to 8
                            sx=x+dirX(d) : sy=y+dirY(d)
                            if sx>=1 and sx<=400 and sy>=1 and sy<=400 then
                                if oldBright(sx,sy) then
                                    if foundAdjacent=0 then
                                        foundAdjacent=d
                                    else
                                        'foundAdjacent=9 'more than one adjacent
                                    end if
                                end if
                            end if
                        next d
                        select case foundAdjacent
                        case 1,2,3,4,5,6,7,8
                            sx=x+dirX(foundAdjacent) : sy=y+dirY(foundAdjacent)
                            #g "color ";255;" ";0;" ";0
                            #g "set ";sx+10;" ";sy+10
                            'print ,,"FOUND ADJACENT"
                        case 9
                        case 0
                            'print "foundAdjacent=0"
                        case else
                            notice "huh?!"
                            wait
                        end select

                    end if
                else
                    bright(x,y)=0
                end if
            next x
            scan
        next y
        for x = 1 to 400
        for y = 1 to 400
            oldBright(x,y)=bright(x,y)
        next y
        next x

next

wait

[QUIT]
close #g
end



function value(x$)
    select case len(x$)
        case 1
        value = asc(x$)
        case 2
        value=asc(mid$(x$,1,1))
        value=value+(asc(mid$(x$,2,1))*256)
        case 4
        value=asc(mid$(x$,1,1))
        value=value+(asc(mid$(x$,2,1))*256)
        value=value+(asc(mid$(x$,3,1))*65536)
        value=value+(asc(mid$(x$,4,1))*16777216)
    end select
end function
 
« Last Edit: Jun 17th, 2012, 1:42pm by Rod » User IP Logged

Rod
Administrator
ImageImageImageImageImage


member is offline

Avatar

Graphics = Goosebumps!


PM

Gender: Male
Posts: 3151
xx Re: Comet Tracking Fun
« Reply #6 on: Jun 12th, 2012, 10:09am »

Speed may indeed be an identifying factor but direction probably more so. While my images move at a set rate in real world images the speed of all the stars progress across the night sky and the speed of the comet will vary. So I guess direction of travel would be a more robust solution.
User IP Logged

NJames
Senior Member
ImageImageImageImageImage


member is offline

Avatar




PM


Posts: 661
xx Re: Comet Tracking Fun
« Reply #7 on: Jun 12th, 2012, 10:49am »

I'm very close. My program is attempting to identify each bright object in the sky and determine which direction it is moving. Groups of adjacent bright pixels are considered a single object and I check to see which object from the previous picture is closest to the location of each object in the current picture, those are assumed to be identical. Thus, we can determine speed and direction.

There are some problems with this method. Objects that are very close may be mistaken as the same object, so we may confuse objects crossing each other's path. Also, there is a sort of 'horizon problem,' where stars drop off the edge of the bitmap, briefly giving the appearance of moving a different direction.

Has anyone else started working on this challenge?
User IP Logged

tsh73
JB-Supporter


member is offline

Avatar




PM

Gender: Male
Posts: 3636
xx Re: Comet Tracking Fun
« Reply #8 on: Jun 12th, 2012, 12:51pm »

Code:
Has anyone else started working on this challenge? 

I have a mental picture as of what am I going to do (several days of mental notices so to speak). And of course it looks perfect - *before* I start coding ;)

So, have to make some productive time to try it.
« Last Edit: Jun 12th, 2012, 12:51pm by tsh73 » User IP Logged

Q: "And if I took your codes and compile them, and sell them for a profit"?
A: Go ahead. I had my share of good then I coded it for fun, if you can make better use of it - please do.
(enjoying JB 1.01 on WinXP, netbook and desktop)
Rod
Administrator
ImageImageImageImageImage


member is offline

Avatar

Graphics = Goosebumps!


PM

Gender: Male
Posts: 3151
xx Re: Comet Tracking Fun
« Reply #9 on: Jun 12th, 2012, 1:10pm »

Deceptively complex. Like Tsh73 I have been enjoying several sleepless nights postulating partial solutions to bits of the problem.

I think this will run for a while so don't be too anxious for a fast fix.
User IP Logged

AltBas
Full Member
ImageImageImageImage


member is offline

Avatar




PM


Posts: 461
xx Re: Comet Tracking Fun
« Reply #10 on: Jun 12th, 2012, 9:18pm »

Hint for development: create your own set of 100 x 100 .bmp, these load in 2 seconds versus 14 seconds for the 400 x 400 set. ;)

Here is my solution.
Code:
'*** Find_Comet.Jb - Find Comet moving different direction than Stars ***
  '* Only works with 24-bit and 32-bit color .bmps *
  '* Have to scan around the trail, as the comet trail isn't solid *

GLOBAL gBufLen, gBufPtr, gBuf$
GLOBAL gXDim, gYDim, gPxlSz, gMinHue

dim Map(1, 1)
dim O(5, 500)  '* A star trail {XBgn, YBgn, XEnd, YEnd, Length} *
  '* Object line slope has a problem of vertical / undefined... *
  '* To compare slopes, could use YDelta and XDelta *
  '* Final solution: Convert slope to radians *
  '* A faster version would save each picture in an array, and would *
    '* only need to load the next picture *
    '* PrvPic = -1 : CurPic = 0 *
    '* PrvPic = ((PrvPic + 1) MOD 4) + 1 *
    '* CurPic = ((CurPic + 1) MOD 4) + 1 *
dim Rdn(0)  '* Angle of object travel to nearest 0.1 radian *

gMinHue = 48  '* Objects dimmer than this are discarded *

Bmps = 10

for a = 1 to Bmps
  N$ = "bmp"+ str$(a) + ".bmp"
  print "Reading "; N$;"  ";
  Bgn = time$("seconds")
  call ReadBMP N$, a
  Don = time$("seconds")
  print "Time: "; Don - Bgn
next a

for a = 0 to gYDim - 1
  for b = 0 to gXDim - 1
    if Map(a,b) < 0 then  '* Found star trail *
      Hue = Map(a,b)  '* Get color *
      YOrg = a : XOrg = b  '* Save the origin *
      y = a : x = b
      YEnd = -1 : XEnd = -1
      call CheckPixel y, x, Hue, YEnd, XEnd  '* Recursive procedure... *
      O(0, ObjCnt) = YOrg  '* Approx object origin *
      O(1, ObjCnt) = XOrg
  [Continue]
      O(2, ObjCnt) = YEnd
      O(3, ObjCnt) = XEnd
      O(4, ObjCnt) = sqr((YOrg - YEnd)^2 + (XOrg - XEnd)^2)
      call Search 8, y, x, Hue  '* Rtns y = -1 as failure, else (y,x) *
      if y > -1 then
        call CheckPixel y, x, Hue, YEnd, XEnd
        goto [Continue]
      end if
      '* Is this object longer than # of .bmps? *
      if O(4, ObjCnt) < Bmps then
        for c = 0 to 4 : O(c, ObjCnt) = 0 : next  '* Remove if short *
      else
        ObjCnt = ObjCnt + 1
        if ObjCnt > 500 then exit for
      end if
    end if
  next b
  if ObjCnt > 500 then print "Too many objects" : exit for
next a

if ObjCnt = 0 then print "No objects found" : END
ObjCnt = ObjCnt - 1
cls
print "Initial Object count: "; ObjCnt

AvgLen = 0 : MaxLen = 0
for a = 0 to ObjCnt
  AvgLen = AvgLen + O(4, a)
  if MaxLen < O(4, a) then MaxLen = O(4, a)
  Tmp = O(3,a) - O(1,a)
  if Tmp <> 0 then
    Tmp = int(atn((O(2,a) - O(0,a)) / Tmp) * 10 + 0.5)
    if Tmp < 0 then Tmp = 63 + Tmp  '* Negative radians *
    O(5,a) = Tmp
  else
    O(5, a) = 0
  end if
next a
AvgLen = ((AvgLen - MaxLen) / ObjCnt) + 1

a = 0
DO  '* Remove short objects *
  if O(4, a) < AvgLen then
    for b = a to ObjCnt
      for c = 0 to 5
        O(c, b) = O(c, b+1)
      next c
    next b
    for c = 0 to 5 : O(c, ObjCnt) = 0 : next c  '* Erase last object *
    ObjCnt = ObjCnt - 1
  else
    a = a + 1
  end if
LOOP until a > ObjCnt

print "Final Object Count: "; ObjCnt
print "Object", "Trail Length", "Pixel/Frame"

redim Rdn(63)  '* Angle of object travel to nearest 0.1 radian *
for a = 0 to ObjCnt  '* Add object to class direction *
  Rdn(O(5,a)) = Rdn(O(5,a)) + 1
next a

' find how much whitespace the windows scheme is taking
' Anatoly's tip
  WindowWidth = 200
  WindowHeight = 200
  open "Ajusting..." for graphics_nf_nsb as #temp
  #temp, "home ; down ; posxy w h"
  w=200-2*w : h = 200-2*h
  close #temp

' setup a BMP graphics view
  WindowWidth  = gXDim+w
  WindowHeight = gYDim+h
  UpperLeftX   = (DisplayWidth-WindowWidth)/2
  UpperLeftY   = (DisplayHeight-WindowHeight)/2
  open "Starfield" for graphics_nf_nsb as #g
  #g "trapclose [quit]"
  #g "down"

  for a = 0 to ObjCnt
    #g "line ";O(1,a);" ";O(0,a);" ";O(3,a);" ";O(2,a)
    Hyp = sqr((O(1,a)-O(3,a))^2 + (O(0,a)-O(2,a))^2)
    Vel = Hyp / Bmps
    print a, using("####.#",Hyp), using("###.##",Vel), O(5,a)
  next a
  print "Average Trail Length = "; AvgLen : print
  #g "color RED"
  for a = 0 to ObjCnt
    if O(4, a) > (AvgLen * 2) then
      #g "line ";O(1,a);" ";O(0,a);" ";O(3,a);" ";O(2,a)
      print "Object "; using("###",a);" possible non-star"
    else
      if (Rdn(O(5,a)) = 1) then
        if (Rdn((O(5,a) + 1) AND 63) = 0 AND Rdn((O(5,a) - 1) AND 63) = 0) then
          print "Object "; using("###",a);" possible non-star"
        end if
      end if
    end if
  next a
  #g "up"
  #g "flush"
  wait
[quit]
  #g "cls"
  CLOSE #g
END

FUNCTION GetInt(NumBytes)
  for a = 0 to NumBytes - 1
    Tmp = Tmp + (asc(mid$(gBuf$, a + gBufPtr, 1)) * 256 ^ a)
  next a
  GetInt = Tmp
  gBufPtr = gBufPtr + NumBytes
END FUNCTION

FUNCTION GetStr$(NumBytes)
  GetStr$ = mid$(gBuf$, gBufPtr, NumBytes)
  gBufPtr = gBufPtr + NumBytes
END FUNCTION

SUB ReadBMP FName$, Level
  open FName$ for input as #1
  gBuf$ = ""
  gBufLen = LOF(#1)
  gBuf$ = input$(#1, gBufLen) : CLOSE #1
  gBufPtr = 1
  if GetStr$(2) <> "BM" then print "Unknown file type" : END
  gBufPtr = 11 : pData = GetInt(4) + 1
  gBufPtr = 19 : Tmp = GetInt(4)
  if gXDim = 0 then gXDim = Tmp  '* First map sets size *
  if Tmp <> gXDim then print "Different sized bitmap" : END
  Tmp = GetInt(4)
  if gYDim = 0 then
    gYDim = Tmp
    redim Map(gYDim, gXDim)
  end if
  if Tmp <> gYDim then print "Different sized bitmap" : END
  gBufPtr = 29 : gPxlSz = GetInt(2) / 8
  if int(gPxlSz) < gPxlSz then gPxlSz = int(gPxlSz + 1)
  if gPxlSz < 3 then print "Unhandled bitmap color depth" : END
  Cmprs = GetInt(4)
  if Cmprs > 0 and Cmprs <> 3 then print "Unhandled compression" : END
  Pad = (gXDim * gPxlSz) mod 4
  if Pad > 0 then Pad = 4 - Pad
  gBufPtr = pData

  '* This inverts .bmp to proper orientation *
  for a = gYDim - 1 to 0 step -1
    for b = 0 to gXDim - 1
      Tmp = GetPixel()
      Map(a, b) = Map(a, b) - Tmp
    next b
    gBufPtr = gBufPtr + Pad
  next a
END SUB

FUNCTION GetPixel()
  '* Convert 24- and 32-bit pixels to gray scale; returns 0 - 255 *
  '* Add together 30% of Red, 59% of Grn, 11% of Blu *
  Tmp = asc(mid$(gBuf$, gBufPtr, 1)) * 0.30  '* Blue *
  Tmp = Tmp + asc(mid$(gBuf$, gBufPtr + 1, 1)) * 0.59  '* Green *
  Tmp = int(Tmp + asc(mid$(gBuf$, gBufPtr + 2, 1)) * 0.11 + 0.5)  '* Red *
  if Tmp < gMinHue then Tmp = 0  '* Discard dim objects *
  GetPixel = Tmp
  gBufPtr = gBufPtr + gPxlSz
END FUNCTION

SUB CheckPixel y, x, Hue, BYREF YLast, BYREF XLast
  '* A recursive procedure *
  '* Hue is a negative number *
  '* On actual photo, probably don't need to check diagonals *
    '* Just Up/Dn/Lft/Rgt, as objects are multi-pixel wide/high *
    '* But in test .bmp objects can be 1 pixel wide *
  if Map(y,x) = Hue then
    Map(y,x) = abs(Map(y,x))
    YLast = y
    XLast = x
    if y > 0 then call CheckPixel y-1, x, Hue, YLast, XLast  '* N *
    if y > 0 and x < gXDim - 1 then call CheckPixel y-1, x+1, Hue, YLast, XLast  '* NE *
    if x < gXDim - 1 then call CheckPixel y, x+1, Hue, YLast, XLast '* E *
    if y < gYDim - 1 and x < gXDim - 1 then call CheckPixel y+1, x+1, Hue, YLast, XLast  '* SE *
    if y < gYDim - 1 then call CheckPixel y+1, x, Hue, YLast, XLast '* S *
    if y < gYDim - 1 and x > 0 then call CheckPixel y+1, x-1, Hue, YLast, XLast  '* SW *
    if x > 0 then call CheckPixel y, x-1, Hue, YLast, XLast  '* W *
    if y > 0 and x > 0 then call CheckPixel y+1, x+1, Hue, YLast, XLast  '* NW *
  end if
END SUB

SUB Search Rds, BYREF y, BYREF x, Hue
'*** Look for continuation of trail ***
  '* This is called after CheckPixel terminates *
  '* Radius (Rds) should be based on time difference between photos *
  '* Want to find closest object within Radius *
  '* Quicker search would only scan a cone along slope from object *
    '* and prevent false matches *
  '* Real photo objects would be spheres, and won't have detectable *
    '* true object axis.  Real star trails would have known *
    '* (and expected) consistent difference (center to center) and *
    '* angle (I guess) *
  if Map(x,y) <> Hue then
    Dist = (Rds + 2)^2  '* Out of range object distance value *
    xTmp = x : yTmp = y : x = -1 : y = -1  '* save Pt, rtn NotFound *
    ty = yTmp - Rds : if ty < 0 then ty = 0
    tx = xTmp - Rds : if tx < 0 then tx = 0
    by = yTmp + Rds : if by >= gYDim then by = gYDim - 1
    bx = xTmp + Rds : if bx >= gXDim then bx = gXDim - 1
    for a = ty to by
      for b = tx to bx
        if Map(a, b) = Hue then
          Tmp = (yTmp - a)^2 + (xTmp - b)^2
          if Tmp < Dist then Dist = Tmp : y = a : x = b
        end if
      next b
    next a
  end if
END SUB 

I read the document in pberrett's link to imm5511.pdf, and I based my solution on the pixel subtraction stage (after converting to grayscale), and the fact that comets move faster than the stars apparent movement. The subtraction actually removes stars, except for the start and end points / arcs.

My algorithm: anything shorter than the number of pictures in the set is ignored (1st pass); anything slower than the average velocity is ignored (2nd pass). Anything moving over 2x the average velocity is reported as possible comet.

Of course, the actual photos will have gradational edges into the body of the main object, so edges won't be so obvious. Hope I haven't poisoned anyone's ideas of how to do it...

I had to hardcode a distance to search around the end of an object to find a possible continuation which I'm not too happy about, but there isn't much way around it without more information.

- AltBas
Edit: Modified 2012-06-13 13:20 UTC to add angle test (radians)
« Last Edit: Jun 13th, 2012, 08:46am by AltBas » User IP Logged

NJames
Senior Member
ImageImageImageImageImage


member is offline

Avatar




PM


Posts: 661
xx Re: Comet Tracking Fun
« Reply #11 on: Jun 13th, 2012, 08:06am »

Here's my submission

Code:
        'nomainwin
        WindowWidth=550
        WindowHeight=550
        open "test" for graphics as #g
        #g "trapclose [QUIT]"
        #g "down ; fill black"
        #g "place 10 10 ; color white ; box 411 411"

    dim bright(400,400)
    dim filled(400,400)

    maxObjects=200
    dim object(maxObjects,5) 'x, y, dir, spd, size
    dim oldObject(maxObjects,5)

    ' 7 8 1
    ' 6 . 2
    ' 5 4 3
    dim dirX(8)
    dim dirY(8)
    dirX(1)=1  : dirY(1)=-1
    dirX(2)=1  : dirY(2)=0
    dirX(3)=1  : dirY(3)=1
    dirX(4)=0  : dirY(4)=1
    dirX(5)=-1 : dirY(5)=1
    dirX(6)=-1 : dirY(6)=0
    dirX(7)=-1 : dirY(7)=-1
    dirX(8)=0  : dirY(8)=-1

    dim common(8)   'count the number of objects moving in one of 8 directions

for whichBmp = 1 to 10 step 1
    redim bright(400,400)
    fileName$="bmp";whichBmp;".bmp"
    Open fileName$ For Binary As #bmp
        'get the length of the file
        lenFile = lof(#bmp)

        'get bmp info
        info$ = input$(#bmp,54)

        'extract bmp info
        bmpWidth = value(mid$(info$,19,2))'width in pixels of image
        bmpHeight = value(mid$(info$,23,2))'height in pixels of image
        bmpOffset = value(mid$(info$,11,4))'offset in file to pixel data 54 or 66 for Liberty bmps
        bmpColDepth = value(mid$(info$,29,2))/8 'color depth, 32bit/4bytes or 24bit/3bytes

        'work out padding, a raster must end on a 4 byte boundary
        rasterWidth=bmpWidth * bmpColDepth
        p=rasterWidth mod 4
        if p=3 then rasterWidth=rasterWidth+1
        if p=2 then rasterWidth=rasterWidth+2
        if p=1 then rasterWidth=rasterWidth+3

        print
        print fileName$
        print "Width ";bmpWidth
        print "Height ";bmpHeight
        print "Offset ";bmpOffset
        print "Color Depth ";bmpColDepth
        print "No bytes in raster ";rasterWidth

        'set pointer to first of color quad or triplet info
        seek #bmp,bmpOffset

        'load pixel data
        pixel$=input$(#bmp,lenFile-bmpOffset)
        pos=1
        for pixel=1 to 12
            print "color ",str$(pixel);",";
            print asc(mid$(pixel$,pos,1));",";
            print asc(mid$(pixel$,pos+1,1));",";
            if bmpColDepth>3 then
                print asc(mid$(pixel$,pos+2,1));",";
                print asc(mid$(pixel$,pos+3,1))
            else
                print asc(mid$(pixel$,pos+2,1))
            end if
            pos=pos+bmpColDepth
        next pixel
        close #bmp

        'draw bright objects on screen as they appear in bitmap (white/gray)
        'bright pixels are recorded in bright(x,y)
        pos=1
        for y = bmpHeight to 1 step -1
            for x = 1 to bmpWidth
                red=asc(mid$(pixel$,pos,1))
                green=asc(mid$(pixel$,pos+1,1))
                if bmpColDepth>3 then
                    blue=asc(mid$(pixel$,pos+2,1))
                    'print asc(mid$(pixel$,pos+3,1))
                    pos=pos+4
                else
                    blue=asc(mid$(pixel$,pos+2,1))
                    pos=pos+3
                end if
                if red+green+blue>100 then
                    bright(x,y)=1
                    #g "color ";red;" ";green;" ";blue
                    #g "set ";x+10;" ";y+10
                end if
            next x
            scan
        next y

    'individual objects are identified by isolated groups of bright pixels
    '
    'we search the bright(x,y) array and upon finding a bright pixel, we then
    'list it as a new object then list all the contiguous bright pixels as
    '"filled" or found.
    '
    'this process is demonstrated graphically with a red pixel indicating each
    'object and the rest of the associated pixels filled in blue
    print "FILLING OBJECTS"
    objects=0
    redim filled(400,400)
    for x = 1 to 400
        for y = 1 to 400
            if bright(x,y) and not(filled(x,y)) then
                objects=objects+1
                object(objects,1)=x
                object(objects,2)=y
                call fillObject x, y, size
                object(objects,5)=size
                #g "color ";255;" ";0;" ";0
                #g "set ";x+10;" ";y+10
                print "#";objects,"coord:";object(objects,1);",";object(objects,2),"size:";object(objects,5)
                'print "#";objects,oldObject(objects,1);",";oldObject(objects,2),oldObject(objects,5)

                'Starting with the 2nd bmp, we check for the nearest object in the previous slide.
                'This is assumed to be the identical object in its previous position. From this
                'we determine speed and direction.
                if whichBmp>1 then
                    closest=0 : closeDist=1000
                    for o = 1 to 100
                        ox = oldObject(o,1)
                        oy = oldObject(o,2)
                        dist=sqr(abs(ox-x)*abs(ox-x)+abs(oy-y)*abs(oy-y))
                        if dist<closeDist then closeDist=dist : closest=o
                    next o
                    print "#";objects;" is closest to old #";closest,closeDist,
                    ox=oldObject(closest,1) : oy=oldObject(closest,2)
                    select case
                    case ox>x and oy>y
                        dir=3
                    case ox>x and oy<y
                        dir=1
                    case ox>x and oy=y
                        dir=2
                    case ox<x and oy>y
                        dir=5
                    case ox<x and oy<y
                        dir=7
                    case ox<x and oy=y
                        dir=6
                    case ox=x and oy>y
                        dir=4
                    case ox=x and oy<y
                        dir=8
                    case ox=x and oy=y
                        dir=0
                    end select
                    object(objects,3)=dir
                    print "dir=";dir
                    common(dir)=common(dir)+1   'the number of times a given direction was observed
                end if
            end if
        next y
    next x

    'We now check how many apparent directions were found in comparing
    'the last two bitmaps. If the number is 2, we assume we have identified
    'the comet and briefly circle it in white.
    directionsObserved=0
    for c = 0 to 8
        if common(c)>0 then directionsObserved=directionsObserved+1
    next c
    if directionsObserved=2 then
        for obj = 1 to maxObjects
            dir = object(obj,3)
            if common(dir)=1 then
                x=object(obj,1)
                y=object(obj,2)
                #g "place ";x+10;" ";y+10
                #g "color white ; size 1"
                #g "circle 12"
                timer 1500, [continue]
                wait
                [continue]
                timer 0
                #g "color black ; size 1"
                #g "circle 12"
            end if
        next obj
    end if
    print "Directions Observed = ";directionsObserved
    redim common(8)

    for o = 1 to maxObjects
        oldObject(o,1)=object(o,1)
        oldObject(o,2)=object(o,2)
        oldObject(o,3)=object(o,3)
        oldObject(o,4)=object(o,4)
        oldObject(o,5)=object(o,5)
    next o

next



wait

[QUIT]
close #g
end



function value(x$)
    select case len(x$)
        case 1
        value = asc(x$)
        case 2
        value=asc(mid$(x$,1,1))
        value=value+(asc(mid$(x$,2,1))*256)
        case 4
        value=asc(mid$(x$,1,1))
        value=value+(asc(mid$(x$,2,1))*256)
        value=value+(asc(mid$(x$,3,1))*65536)
        value=value+(asc(mid$(x$,4,1))*16777216)
    end select
end function

sub fillObject x, y, byref size
    list$="|";x;",";y;"|"
    items=1 : index=0
    while index<items
        'get next point from list
        index=index+1
        pair$=word$(list$,index+1,"|")  'coordinate pair from list
        x = val(pair$)
        y = val(word$(pair$,2,","))

        'fill
        filled(x,y)=1
        #g "color ";0;" ";0;" ";255
        #g "set ";x+10;" ";y+10

        'check for adjacent points
        for d = 1 to 8
            sx=x+dirX(d)
            sy=y+dirY(d)
            'bounds checking
            if sx>=1 and sx<=400 and sy>=1 and sy<=400 then
                newPair$="|";sx;",";sy;"|"
                if bright(sx,sy) AND not(instr(list$,newPair$)) then
                    'add to list
                    list$=list$;sx;",";sy;"|"
                    items=items+1
                end if
            end if
        next d
    wend

    'find center

    size=items
end sub
 
« Last Edit: Jun 17th, 2012, 1:42pm by Rod » User IP Logged

NJames
Senior Member
ImageImageImageImageImage


member is offline

Avatar




PM


Posts: 661
xx Re: Comet Tracking Fun
« Reply #12 on: Jun 13th, 2012, 08:18am »

on Jun 12th, 2012, 9:18pm, AltBas wrote:
I had to hardcode a distance to search around the end of an object to find a possible continuation which I'm not too happy about, but there isn't much way around it without more information.

My method doesn't hard code a search distance, but it does need some way to discard bogus results.
User IP Logged

Rod
Administrator
ImageImageImageImageImage


member is offline

Avatar

Graphics = Goosebumps!


PM

Gender: Male
Posts: 3151
xx Re: Comet Tracking Fun
« Reply #13 on: Jun 13th, 2012, 3:03pm »

Two fine efforts so far and a winner. I wonder if Peter could supply some real images for folks to play with once they have the basic checking routines debugged?

I do hope folks will continue to post. I am really keen to see how people break the problem down. There will be more than one way to solve this. Speed, accuracy, tricks and tips, Thats what we need.

I am still figuring how to calculate mass and color and centre and direction indeed match star to star. So I'm still having fun.

We have a winner but this will run and run so please let us see how you would tackle it.

Incomplete solutions, half done problems and hints and tips are all welcome.
User IP Logged

tsh73
JB-Supporter


member is offline

Avatar




PM

Gender: Male
Posts: 3636
xx Re: Comet Tracking Fun
« Reply #14 on: Jun 13th, 2012, 3:25pm »

My program is working but as of now, code needs tyding up.
Will post then "comb" it a bit.

And it really needs only two pictures sad
(because displacement is constant, any difference stands out).
Probably example given just too uniform. To try on real pictures will be really interesting.
User IP Logged

Q: "And if I took your codes and compile them, and sell them for a profit"?
A: Go ahead. I had my share of good then I coded it for fun, if you can make better use of it - please do.
(enjoying JB 1.01 on WinXP, netbook and desktop)
Pages: 1 2 3  Notify Send Topic Print
« Previous Topic | Next Topic »

Conforums Terms of Service | Membership Rules | Home | Search | Recent Posts | Notification | Format Your Message | Installation FAQ

Donate $6.99 for 50,000 Ad-Free Pageviews!

| |

This forum powered for FREE by Conforums ©
Sign up for your own Free Message Board today!
Terms of Service | Privacy Policy | Conforums Support | Parental Controls