Board Logo
« Comet Tracking Fun »

Welcome Guest. Please Login or Register.
Jan 16th, 2018, 3:41pm


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 351 times)
AltBas
Full Member
ImageImageImageImage


member is offline

Avatar




PM


Posts: 461
xx Re: Comet Tracking Fun
« Reply #15 on: Jun 13th, 2012, 11:05pm »

You can get photos from the NASA SOHO image search website. He was using the LASCO (Large Angle and Spectrometric COronagraph) C2 images, which cover 1.1 solar radii. There are also C3 images which cover 32 solar radii - which are much more busy.

- AltBas
User IP Logged

pberrett
Member in Training
ImageImage


member is offline

Avatar




PM


Posts: 42
xx Re: Comet Tracking Fun
« Reply #16 on: Jun 14th, 2012, 06:46am »

Hi again everyone

Sorry but I have been busy writing my first BASIC program in 30 years!

I have succeeded in writing a program which will examine 4 LASCO c2 images (follow the link above) to hunt for comets. Its still at a rudimentary stage but I have proof of concept.

What I think is rather nifty about my program is the way is can distinguish between stars and areas of general brightness such as occur when there is a solar flare. It is pretty good at picking out stars and similar objects and can distinguish objects that are faint.

Further the program now eliminates stars (it does so by eliminating objects that move in the same plane as stars) to leave objects moving in other directions.

To put this in perspective when I first ran the program I was getting hundreds of hits ie 4 objects in a straight line evenly space on the 4 images. Now I generally get 3 or 4.

My work tonight is on getting the program to do the same thing but with 4 images that are not evenly spaced ie one 5 minutes after the first, then 13 minutes later then 20 minutes later.

One of the biggest challenges is that typically I find about 1200 bright dots in each image. Working out 4 dots in a straight line at varying time intervals across 4 images, each with 1200 dots is a big load on the computer. Thanks to some careful assumptions and knowledge about how fast comets move I have been able to get the whole analysis of 4 images from beginning to end down to about 15 minutes.

This is still too long for my purposes however as I am working towards batch processing a day's worth of c2 images at a time (about 120 images). The idea is to process images 1,2,3,4 then process 2,3,4,5 then 3,4,5,6 etc. Once that is done the results would be compared and combined so that objects that extend over say 8 images could be identified. The objects that extend in a straight line over the most sequential images would be ranked highest.

As I have been writing this post I have been running the latest iteration of my program and I can confirm that it now will handle images of uneven time spacing. The latest batch test took 5 images evenly spaced at 12 minutes with a known comet in them and I omitted the second image so that I had 0500, 0524,0536,0548 (minutes) from 20120607.

Here's the output

(x1,y2) (x2,y2)(x3,y3),(x4,y4)


82 44 82 50 82 53 82 56
62 959 69 964 72 967 76 970
729 976 732 961 733 954 735 947
729 976 731 962 732 955 733 948
729 976 731 962 732 955 734 948
730 976 732 961 733 954 734 947
730 976 732 961 733 954 735 947
730 976 731 962 732 955 733 948
730 976 732 962 733 955 734 948
728 977 731 962 732 954 734 947
728 977 731 962 733 954 735 947
728 977 730 962 731 955 733 948
728 977 731 962 732 955 734 948
729 977 731 962 732 954 733 947
729 977 731 962 732 954 734 947
729 977 732 962 733 954 735 947
729 977 731 962 732 955 733 948
729 977 731 962 732 955 734 948
730 977 731 962 732 954 733 947
730 977 732 962 733 954 734 947
730 977 732 962 733 954 735 947
730 977 731 962 732 955 733 948
730 977 732 962 733 955 734 948
728 978 731 962 732 954 734 946
728 978 731 962 733 954 735 946
728 978 731 962 732 954 734 947
728 978 731 962 733 954 735 947
728 978 730 963 731 955 733 948
728 978 731 963 732 955 734 948
729 978 731 962 732 954 733 946
729 978 731 962 732 954 734 946
729 978 732 962 733 954 735 946
729 978 731 962 732 954 733 947
729 978 731 962 732 954 734 947
729 978 732 962 733 954 735 947
729 978 731 963 732 955 733 948
729 978 731 963 732 955 734 948
730 978 731 962 732 954 733 946
730 978 732 962 733 954 734 946
730 978 732 962 733 954 735 946
730 978 731 962 732 954 733 947
730 978 732 962 733 954 734 947
730 978 732 962 733 954 735 947
730 978 731 963 732 955 733 948
730 978 732 963 733 955 734 948
887 1006 888 994 888 988 889 983


cheers Peter




« Last Edit: Jun 14th, 2012, 06:49am by pberrett » User IP Logged

pberrett
Member in Training
ImageImage


member is offline

Avatar




PM


Posts: 42
xx Re: Comet Tracking Fun
« Reply #17 on: Jun 14th, 2012, 07:00am »

The comet was already known to be entering the images (it had been seen in a wider view image) so the following had been reported

Known comet now entering:
Images: C2; 1024x1024 images.
(0,0) Upper Left.
20120607
Kreutz group comet.
0348 720 1019
0400 721 1012
--Sergei Schmalz

You can extrapolate to the coordinates at my later images.

cheers Peter
User IP Logged

pberrett
Member in Training
ImageImage


member is offline

Avatar




PM


Posts: 42
xx Re: Comet Tracking Fun
« Reply #18 on: Jun 14th, 2012, 07:25am »

I suggest you use those images (download them now before they disappear from the server) as a test bed as they have a comet in them.

Web location

cheers Peter
« Last Edit: Jun 14th, 2012, 5:34pm by Stefan Pendl » User IP Logged

pberrett
Member in Training
ImageImage


member is offline

Avatar




PM


Posts: 42
xx Re: Comet Tracking Fun
« Reply #19 on: Jun 14th, 2012, 07:37am »

Also I have a bit of a problem that I hope someone will help me with.

The first part of Gromit (my codename for this program) is the following code. Also to quicken things up my bmp files are already converted to 24 bit.



Code:
[start]
Input "Number of files?   ";nbr
print nbr
if nbr >3 and nbr<11 then goto [jump1]
print "Sorry, I can't do that Dave"
print "Try again"
goto [start]

[jump1]
dim  datetime (nbr,2)
dim stars (40000,2)                    ' an array to hold the cordinates where there are dots of light

dim noise$(nbr)
dim dat$(nbr)
dim tim$(nbr)
dim count(nbr)
dim tim(nbr)

for ggg = 1 to nbr

filedialog "Open .bmp","*.bmp",filename$
    open filename$ for input as #1
        bi$ = Input$(#1,LOF(#1))    ' putting the whole bmp in a string
    close #1
    print "Reading bitmap...#";ggg

noise$(ggg)=bi$

k=1
for k=1 to len(filename$)
b$= Mid$(filename$,(len(filename$)+1-k),1)
if b$="\" then exit for
next k
[fix]
v$=Mid$(filename$,(len(filename$)+2-k))
dat$(ggg)=mid$(v$,1,8)
tim$(ggg)=mid$(v$,10,4)

'note the filename takes the format 20120607_0512_c2.bmp 
tim$ =  tim$(ggg)
gosub [ascconvert]
tim(ggg) = amins
next ggg



...



[ascconvert] 'turns a 4 digit string of hours and minutes into its minutes equivalent

mb1$ = mid$(tim$,1,1)
mb2$ = mid$(tim$,2,1)
mb3$ = mid$(tim$,3,1)
mb4$ = mid$(tim$,4,1)

mb1= ((asc(mb1$)-48)*600)
mb2= ((asc(mb2$)-48)*60)
mb3= ((asc(mb3$)-48)*10)
mb4= ((asc(mb4$)-48))

amins = mb1 + mb2 + mb3 + mb4

return

 


As you can see I load each individual image up one at a time. Can this be modified so that I open up one directory and using the shift and control keys I load up a series of files eg 10 at a time??

cheers Peter
User IP Logged

Jimmu
Junior Member
ImageImageImage


member is offline

Avatar




PM

Gender: Male
Posts: 119
xx Re: Comet Tracking Fun
« Reply #20 on: Jun 14th, 2012, 5:54pm »

You wouldn't by any chance have a link to some pics pointing away from the sun would you? I'd like to try my hand at something a bit less cluttered before I jump into the deep end....
User IP Logged

I know many things. Some of them are even true!
NJames
Senior Member
ImageImageImageImageImage


member is offline

Avatar




PM


Posts: 661
xx Re: Comet Tracking Fun
« Reply #21 on: Jun 14th, 2012, 9:19pm »

on Jun 14th, 2012, 07:37am, pberrett wrote:
open up one directory and using the shift and control keys I load up a series of files eg 10 at a time??
I'm thinking of the FILES command... I think it might be usable to grab every .bmp file in a directory. hmmm...
User IP Logged

AltBas
Full Member
ImageImageImageImage


member is offline

Avatar




PM


Posts: 461
xx Re: Comet Tracking Fun
« Reply #22 on: Jun 15th, 2012, 12:34am »

It's best to focus your speed-up efforts on code in the loops. This:
Code:
[ascconvert] 'turns a 4 digit string of hours and minutes into its minutes equivalent

mb1$ = mid$(tim$,1,1)
mb2$ = mid$(tim$,2,1)
mb3$ = mid$(tim$,3,1)
mb4$ = mid$(tim$,4,1)

mb1= ((asc(mb1$)-48)*600)
mb2= ((asc(mb2$)-48)*60)
mb3= ((asc(mb3$)-48)*10)
mb4= ((asc(mb4$)-48))

amins = mb1 + mb2 + mb3 + mb4

return 
Will run marginally faster as this:
Code:
[ascconvert] 'turns a 4 digit string of hours and minutes into its minutes equivalent
amins = ((asc(mid$(tim$,1,1))-48)*600) + _
  ((asc(mid$(tim$,2,1))-48)*60) + _
  ((asc(mid$(tim$,3,1))-48)*10) + _
  ((asc(mid$(tim$,4,1))-48))
return

'* Although this is simpler *
amins = (val(mid$(tim$,1,2))*60) + val(mid$(tim$,3,2)) 

My tests show a long (probably complex) expression will execute faster than several intermediate assignments to temp variables. But you should make sure your equation works using the temp variables before building the long expression.

The example code, since it is executed so few times, won't make any difference to the speed of your application. Focus on the most frequently executed code. And don't forget to save versions of your code to fall back on if you forget quite what you have tweaked when you broke it...

- AltBas
User IP Logged

Jimmu
Junior Member
ImageImageImage


member is offline

Avatar




PM

Gender: Male
Posts: 119
xx Re: Comet Tracking Fun
« Reply #23 on: Jun 15th, 2012, 03:43am »

Here's something I cobbled together from what I found in the help file:
Code:
'    info$(0, 0) - a string specifying the qty of files found
'    info$(0, 1) - a string specifying the qty of subdirectories found
'    info$(0, 2) - the drive spec
'    info$(0, 3) -  the directory path

'Starting at info$(1, x) you will have file information:

'    info$(n, 0) - the file name
'    info$(n, 1) - the file size
'    info$(n, 2) - the file date/time stamp
'    info$(n, 3) - ??? access ??? maybe
Dim info$(0,0)

filedialog "Open one file in the directory", "*.bmp", fullPath$
print "File chosen is ";fullPath$

l = 1
While Instr(fullPath$,"\",l) > 0
    l = Instr(fullPath$,"\",l) + 1
Wend


p$ = Left$(fullPath$,l - 1)
f$ = Mid$(fullPath$,l)
m$ = "*" + Mid$(f$,Instr(f$,"."))

print "Path is ";p$
print "Filename is ";f$
print "Mask is ";m$

files p$, m$, info$()

For i = 1 to Val(info$(0,0))
    print info$(i,0), info$(i,1), info$(i,2), info$(i,3)
Next i

end
 

I couldn't figure out any way to get just a directory path from the filedialog command so I had to kludge it a bit. You could use info$() to feed a listbox and then select file names there....
User IP Logged

I know many things. Some of them are even true!
Rod
Administrator
ImageImageImageImageImage


member is offline

Avatar

Graphics = Goosebumps!


PM

Gender: Male
Posts: 3151
xx Re: Comet Tracking Fun
« Reply #24 on: Jun 16th, 2012, 03:39am »

There are a lot of images on the ftp site, can you specify what three or four we should download?
User IP Logged

Rod
Administrator
ImageImageImageImageImage


member is offline

Avatar

Graphics = Goosebumps!


PM

Gender: Male
Posts: 3151
xx Re: Comet Tracking Fun
« Reply #25 on: Jun 16th, 2012, 12:57pm »

OK this is my first attempt. It reads two 24bit images 400x400. It loads the bmps to a string then an array. Might try just reading the string on the next effort.

I have kept this very simplistic, I look for the centre point of any star on the x axis by noting the left starting edge and the right trailing edge. I work out the middle point. So one star will have many entries in the star table. A line on the y axis if you like.

Then I sum all of the x positions and find the average variance between bmp1 and bmp2. This provides the average xdelta. So too for the y axis and ydelta

Then I simply delete parts of the star line that have moved to the expected xdelta ydelta position.

Anything left is not moving the same way the star lines are.

It needs work, a lot of work. It is fooled by stars at the edge of the image and it is way to slow for bigger images so some optimisation required.

But it works and you can watch it happen before your very eyes!

EDIT: A bug requires that the bmps don't lose any stars off the edges. Some special, uniform bmps here.

Code:
 'nomainwin
    bmpHeight=400
    bmpWidth=400
    pixels=bmpWidth*bmpHeight
    dim bmp1(pixels)
    dim bmp2(pixels)
    dim star1(500,3) 'x,y,size
    dim star2(500,3)

    WindowWidth=bmpWidth*2+30
    WindowHeight=bmpHeight+100
    open "test" for graphics_nf_nsb as #g
    #g "trapclose [quit]"
    #g "down"
    loadbmp "bmp1","bmp1.bmp"
    loadbmp "bmp2","bmp2.bmp"
    #g "down ; drawbmp bmp1 10 10"
    #g "down ; drawbmp bmp2 411 10"
    startTime=time$("ms")

    'load bmps to an array
    open "bmp1.bmp" for binary as #bmp
    pixel$=input$(#bmp,lof(#bmp))
    index=1
    for pos=57 to lof(#bmp) '55=b 56=g 57=r
        bmp1(index)=asc(mid$(pixel$,pos,1))
        pos=pos+2
        index=index+1
    next
    close #bmp

    open "bmp2.bmp" for binary as #bmp
    pixel$=input$(#bmp,lof(#bmp))
    index=1
    for pos=57 to lof(#bmp) '55=b 56=g 57=r
        bmp2(index)=asc(mid$(pixel$,pos,1))
        pos=pos+2
        index=index+1
    next
    close #bmp

    print "Load to string$ ";time$("ms")-startTime
    startTime=time$("ms")



    'find the x centre line points of each star
    'store all occurences found and eliminate
    'single point stars
    index=1
    starno=1
    leftedge=0
    rightedge=0
    for y = bmpHeight to 1 step -1
        for x = 1 to bmpWidth
            if bmp1(index)>30 then
                #g "color red ; set ";x+9;" ";y+9
                if leftedge=0 then leftedge=x
                if leftedge>0 then rightedge=x
            else
                if leftedge>0 and rightedge>0 then
                    star1(starno,1)=int(leftedge+(rightedge-leftedge)/2)
                    star1(starno,2)=y
                    star1(starno,3)=rightedge-leftedge+1
                    if leftedge=rightedge then
                        #g "color black ; set ";star1(starno,1)+9;" ";star1(starno,2)+9
                    else
                        #g "color yellow ; set ";star1(starno,1)+9;" ";star1(starno,2)+9
                    end if
                    leftedge=0
                    rightedge=0
                    starno=starno+1
                end if
            end if
            index=index+1
        next x
        scan
    next y

    'same again for bmp2
    stars1=starno-1
    index=1
    starno=1
    leftedge=0
    rightedge=0
    for y = bmpHeight to 1 step -1
        for x = 1 to bmpWidth
            if bmp2(index)>30 then
                #g "color red ; set ";x+410;" ";y+9
                if leftedge=0 then leftedge=x
                if leftedge>0 then rightedge=x
            else
                if leftedge>0 and rightedge>0 then
                    star2(starno,1)=int(leftedge+(rightedge-leftedge)/2)
                    star2(starno,2)=y
                    star2(starno,3)=rightedge-leftedge+1
                    if leftedge=rightedge then
                        #g "color black ; set ";star2(starno,1)+410;" ";star2(starno,2)+9
                    else
                        #g "color yellow ; set ";star2(starno,1)+410;" ";star2(starno,2)+9
                    end if
                    leftedge=0
                    rightedge=0
                    starno=starno+1
                end if
            end if
            index=index+1
        next x
        scan
    next y
    stars2=starno-1


    'sum the whole sky x and y
    'the average variance provides the x and y delta
    for n= 1 to stars1
        x1=x1+star1(n,1)
        y1=y1+star1(n,2)
        x2=x2+star2(n,1)
        y2=y2+star2(n,2)
    next
    xdelta=int((x2-x1)/stars1+.5)
    ydelta=int((y2-y1)/stars1+.5)


    'eliminate stars of similar size at expected delta
    for n= 1 to stars1
        for m= 1 to stars2
            if star2(m,1)=star1(n,1)+xdelta and star2(m,2)=star1(n,2)+ydelta and star2(m,3)=star1(n,3) then
                star1(n,3)=0
            end if
        next
    next

    'check for remaining stars
    for n= 1 to stars1
        if star1(n,3)<>0 then
            #g "color blue ; set ";star1(n,1)+9;" ";star1(n,2)+9
            #g "circle 20"
            found=1
        end if
    next
    if found then print "Potential comet found"
    print "Analysis in ";time$("ms")-startTime


    wait

[quit]
close #g
end



 
« Last Edit: Jun 17th, 2012, 09:57am by Rod » User IP Logged

tsh73
JB-Supporter


member is offline

Avatar




PM

Gender: Male
Posts: 3635
xx Re: Comet Tracking Fun
« Reply #26 on: Jun 16th, 2012, 4:57pm »

mine:
Takes random point - nearest star - empty space around - and looks same spot on another picture.
Repeats several times, tries to select displacement that happens more often.
Run it a few times.
Code:
'Comet Tracking Fun
'contest entry by ths73

global w, h 'for checks in sub checkSpiral 
maxTries = 5
dim d$(maxTries), c(maxTries)
dList$ = ""
nList = 0 

pic1$="bmp1.bmp"
pic2$="bmp10.bmp"    'whatever
'bitmap size?
call GetBmpDimensions pic1$, w, h
print "Picture is ";w;" by ";h
dim bmp(w,h)
dim a(w,h)
dim b(w,h)
'read bitmap in
call readBMPData pic1$
gosub [bmp2a]

'check if second of same dimension
call GetBmpDimensions pic1$, w2, h2
if w<>w2 OR h<>h2 then 
    print "Second picture is ";w;" by ";h
    print "Second picture size differs - so we quit"
    end
end if    
call readBMPData pic2$
gosub [bmp2b]

'try to plot and see what we'll got
gosub [showPicture]

'randomize 0.5
for k = 1 to maxTries
    'get a random point, run in spirals until found bright point
    x0=randRange(20, w-20)
    y0=randRange(20, h-20)
    print "random point ";k;" ";
    'print x0, y0
    if a(x0,y0) then 'already bright point, skip search for star
        goto [pointFound]
    end if
    print #gr1, " color red"
    print #gr1, "set ";x0;" ";y0

    'go in spirals, find first star
    print #gr1, " color yellow"
    dTr = 0
    call checkSpiral x0, y0, dTr, x, y, d
    print "nearest star ";
    'print x, y,
    'print " distance ";d/2
    
    'Now, should check around new found point. Somehow...
    x0=x: y0=y
[pointFound]
    'print "Checking empty space around bright spot"
    print #gr1, " color pink"
    dTr = 5    'allow for briter star (several points)
    call checkSpiral x0, y0, dTr, x, y, d
    'print x, y
    print " gap: max(dx, dy) till next star is ";d/2

'now, d is width/height of empty space around x0 y0
'so d/2 is margin
'and we took half of it, if it big enough (say >=5)
    margin = int(d/4)
    if margin<5 then 
        print "Distance to next star is too small "
        goto [anotherPoint]
    end if
    print "Taking mid bright point from spotted at half gap ";margin
    'count midpoint (we have threshold so it might as well not be x0 y0)
    isFirstPic=1    'array selector, 1 means a(w,h), 0 means b(w,h)
    gosub [getMidPoint]
    xMid1=xMid: yMid1=yMid

    'Now we should took another picture and check same place
    isFirstPic=0
    gosub [getMidPoint]
    print "Displacement is: ", xMid-xMid1, yMid-yMid1
    if abs(xMid-xMid1)>margin OR abs(yMid-yMid1)>margin then
        print "!!! Bogus result"
    else
        dx=xMid-xMid1: dy=yMid-yMid1
        'should store displacement and counter to find one with bigger counter
        d$="|";int(dx);" ";int(dy);"|"
        if instr(dList$, d$)=0 then    'new displacement? add
            d$(nList)=d$
            c(nList)=1
            dList$ = dList$+ d$
            nList=nList+1
        else                            'else find and increment c
            for i = 0 to nList-1
                if d$(i)=d$ then 
                    c(i)=c(i)+1
                    exit for
                end if
            next
        end if
    end if
[anotherPoint]
next k

print
print "Now, using better displacement, ";
best = -1
cMax = 0 
for i = 0 to nList-1
    if c(i)>cMax then 
        cMax=c(i):best =i
    end if
next
d$=mid$(d$(best), 2)
dx=val(word$(d$,1))
dy=val(word$(d$,2))
print dx, dy
print "mark difference in red..."
'now just re-show picture and mark in red anything not occuring on same spot with displacement
print #gr1, "cls"
print #gr1, "fill black"
print #gr1, "color white"

FOR y = 0 to h-1
    scan
    FOR x = 0 TO w-1
        if inRange(x+dx, 0, h-1) and inRange(y+dy, 0, w-1) then
            if a(x, y) then
                if b(x+dx, y+dy) then
                    print #gr1, "color white"
                else
                    print #gr1, "color red"
                end if
                print #gr1, "set ";x;" ";y
            end if
        end if
    NEXT x
next y
#gr1, "flush"

wait

end
'-----------------------------------------------------

[getMidPoint]
    xMid=0: yMid=0: cnt=0
    for x=x0-margin to x0+margin
        for y=y0-margin to y0+margin
            if isFirstPic*a(x, y)+(1-isFirstPic)*b(x, y) then
                cnt=cnt+1
                xMid=xMid+x
                yMid=yMid+y
            end if
        next
    next
    if cnt then 
        xMid=xMid/cnt
        yMid=yMid/cnt
    end if   
    print "Midpoint ";word$("2 1",isFirstPic+1);" "
    print xMid, yMid
return

[showPicture]
    WindowWidth = 200
    WindowHeight = 200
    open "Ajusting..." for graphics_nf_nsb as #temp
        #temp, "home ; down ; posxy cx cy"
        slackW=200-2*cx : slackH = 200-2*cy
    close #temp

    WindowWidth = w+slackW
    WindowHeight = h+slackH
    open pic1$ for graphics_nsb_nf as #gr1
    print #gr1, "trapclose [quit]"
    print #gr1, "down"
    print #gr1, "fill black"
    print #gr1, "color white"

    FOR y = 0 to h-1
        scan
        FOR x = 0 TO w-1
            if a(x, y) then
                print #gr1, "set ";x;" ";y
            end if
        NEXT x
    next y
    #gr1, "flush"
return

[bmp2a]    
    FOR y = 0 to h-1
        FOR x = 0 TO w-1
            a(x, y) =bmp(x, y)
        NEXT x
    next y
return

[bmp2b]    
    FOR y = 0 to h-1
        FOR x = 0 TO w-1
            b(x, y) =bmp(x, y)
        NEXT x
    next y
return


[quit]
    close #gr1
    end
    
sub readBMPData fileName$
    'reads into array bmp(w,h)
    threshold = 50  'supposed to be tweaked
    'based on code supplied by Rod
    Open fileName$ For Binary As #bmp
        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
        bpp = value(mid$(info$,29,2)) 'color depth, 32bit/4bytes or 24bit/3bytes
        bmpColDepth = bpp /8

        'work out padding, a raster must end on a 4 byte boundary
        rasterWidth=bmpWidth * bmpColDepth
        p=rasterWidth mod 4
        if p then rasterWidth=rasterWidth +(4-p)

        print "Bitmap ";fileName$;
            print " ";bmpWidth;
            print " x ";bmpHeight;
            print " ";bpp;" bpp"

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

        'load pixel data
        pixels$=input$(#bmp,lenFile-bmpOffset)
    close #bmp

    'we'll accept only 24 ao 32 bpp images
    'so pixels will be RGB or RGB0
    if bpp <>24 AND bpp <>32 then
        print "bpp value is ";bpp
        print "Come on! JB generated bitmap supposed to be 24 or 32 bpp"
        print "*refuse to continue*"
        end
    end if

    'dimension array. Clears it too
    dim bmp(bmpWidth,bmpHeight)

    'read the data
    print "reading to array ... ";
    c=0
    for y = 0 to bmpHeight-1        
    'and I'll number pixels from 0
    'read line
        aLine$=mid$(pixels$, y*rasterWidth+1, rasterWidth)  'but string numbers from 1
        scan
        for x = 0 to bmpWidth -1
            pixel$=mid$(aLine$, x*bmpColDepth+1, bmpColDepth)
            'since it's greayscale, we'll take only 1st color of RGB stuff
            'and y is reversed
            value = asc(mid$(pixel$, 1, 1))
            if value >= threshold then bmp(x,bmpHeight-1-y) = 1:c=c+1
            'else it stays 0
        next
    next
    'print "Number of bright pixels is ";c
    'print "dark/light ratio is " ;bmpHeight*bmpWidth/c
    'print "average distance between stars supposed to be ";sqr(bmpHeight*bmpWidth/c)/2  '/2 by experiment
    print "done."
end sub

'GetBmpDimensions from FreeForm custom functions
sub GetBmpDimensions fileName$, byref width, byref height
    open fileName$ for input as #gbd
    temp$ = input$(#gbd, 24)
    close #gbd
    width = asc(mid$(temp$, 19, 1))+asc(mid$(temp$, 20, 1))*256
    height = asc(mid$(temp$, 23, 1))+asc(mid$(temp$, 24, 1))*256
end sub

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))*256^2)
        value=value+(asc(mid$(x$,4,1))*256^3)
    end select
end function

function randRange(Min, Max)
    randRange = Min +  random(Max-Min)
end function

function random(n)
    random = int(rnd(1)*n)
end function

sub checkSpiral x0, y0, dTreshold, byRef x, byRef y, byRef d
x=x0
y=y0
d=0
while 1
        x=x+1
        if x>h-1 then exit sub
        'check a(x, y)
        if a(x, y) and d>dTreshold then exit sub
        print #gr1, "set ";x;" ";y
    d=d+1
    for i = 1 to d
        y=y+1
        if y>h-1 then exit sub
        if a(x, y) and d>dTreshold then exit sub
        print #gr1, "set ";x;" ";y
    next
    d=d+1
    for i = 1 to d
        x=x-1
        if x<0 then exit sub
        if a(x, y) and d>dTreshold then exit sub
        print #gr1, "set ";x;" ";y
    next
    for i = 1 to d
        y=y-1
        if y<0 then exit sub
        if a(x, y) and d>dTreshold then exit sub
        print #gr1, "set ";x;" ";y
    next
    for i = 1 to d
        x=x+1
        if x>h-1 then exit sub
        if a(x, y) and d>dTreshold then exit sub
        print #gr1, "set ";x;" ";y
    next
wend
end sub

function inRange(aVal, minVal, maxVal)
    inRange = aVal >= minVal AND aVal <=  maxVal
end function
 
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)
tsh73
JB-Supporter


member is offline

Avatar




PM

Gender: Male
Posts: 3635
xx Re: Comet Tracking Fun
« Reply #27 on: Jun 17th, 2012, 02:31am »

Rod,
your code fails for me for 32bpp.
After some modifications I end up with every of 400 star circled with blue circle - I think that is not desired effect? Probably I broke something while adapting to 32 bpp wink

Not I wonder if my program will give bogus results on 24 bpp as well.
It happens I cannot make 24 bpp - all my computers has options for 32 or 16.

So I posted 32 bpp pictures at archives
source bitmaps for Comet Tracking Fun challenge
Whoever has 24 bpp, please post them too.
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 #28 on: Jun 17th, 2012, 03:45am »

Added my 24 bit bmps.

http://jbfilesarchive.com/phpBB3/viewtopic.php?f=11&t=1780
User IP Logged

tsh73
JB-Supporter


member is offline

Avatar




PM

Gender: Male
Posts: 3635
xx Re: Comet Tracking Fun
« Reply #29 on: Jun 17th, 2012, 08:13am »

Thanks.
My program seems to work on them, too wink
Interesting thing happened then I took one picture from your batch, and another one from mine. Star pattern is different - my program did not managed to get single good rectangle (rectangle with one star from one picture, corresponding with same rectangle with same amount of stars from another picture). So it died trying to select "best" displacement from no good displacements at all.
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