SyntaxBomb - Indie Coders


FillAreas

'--- snip ----

Local mouseDownOn:Int
Local mouseDownX:Int
Local mouseDownY:Int
Local mouseDownEast:Double
Local mouseDownNorth:Double

Repeat
        Local zeit%=MilliSecs()
                Cls
                DrawCircle
                East  = DrawSlider(20,100, East/10, 1,"EAST")*10
                North = DrawSlider(80,100, North/10, 2,"NORTH")*10
               
                If MouseDown(1)
If not mouseDownOn
mouseDownEast = East
mouseDownNorth = North
mouseDownX = MouseX()
mouseDownY = MouseY()
mouseDownOn = True
Else
East = mouseDownEast - (MouseX()-mouseDownX)
North = mouseDownNorth + MouseY()-mouseDownY
EndIf
Else
mouseDownOn = False
EndIf
'--- snip ----
               
                If East<>vEast Or North<>vNorth


Allows a mouse driven rotation

Edit: you might better make negative values there then "positive" --- else your current logic leads to array-out-of-bounds accesses:
        Local g4:Double = g2 * COSIN[EE]
        Local g5:Double = g2 * SINUS[EE]
as "EE" eg becomes negative with this here:
        Local EE:Int=(E-EastM+3600) Mod 3600

incoming params:
E = 0
EastM = 3695 (so bigger than 3600)

Think the formula should be:
Local EE:int = ((E - EastM) Mod 3600 + 3600) Mod 3600
and not
Local EE:Int=(E-EastM+3600) Mod 3600

as it ensures that the difference is between "E" and "EastM" is between "-3600 and +3600" which we then bring to "0 to +7200" - and modulate that back into "0 to 3600"


bye
Ron

Now with coordinates and switchable grid.

for this version you need a copy of "arial.ttf" from your windows-font-folder

SuperStrict

' MapToGlobe.bmx  version 7
' turns a world map into a globe display
' Copyright and original code by Kay63 on SmallBasic
' free example map from "https://asterweb.jpl.nasa.gov/gdem.asp"
Global Arial:TImageFont=LoadImageFont("arial.ttf",12,SMOOTHFONT)
Global GlobeRADIUS:Int=250
Global ScreenMidY:Int=50+GlobeRADIUS
Global ScreenMidX:Int=150+GlobeRADIUS
Graphics ScreenMidX*2,ScreenMidY*2
Global Map:TPixmap = LoadPixmap("GDEM-40km-color.png")
Global Width:Int  = Map.Width
Global Height:Int = Map.Height
Print "height=" + Height
Global East:Double    = -1800  , vEast:Double 'default coordinates
Global North:Double   =  200  , vNorth:Double
Const RADIUS:Double  =   1
Const FACTOR: Double =   1
Global GridOn:Int
Global CountChecks:Int
Global GlobeImage:TImage
Global Area:TArea[Width]

Global SINUS:Double[7200], COSIN:Double[7200]
PreSinus
FillAreas
SetImageFont Arial
SetBlend alphablend
Repeat
Local zeit%=MilliSecs()
Cls
DrawCircle
East  = DrawSlider(20,100, East/10, 1,"EAST")*10
North = DrawSlider(80,100, North/10, 2,"NORTH")*10
GridOn = DrawButton(20,20, GridOn,"GRID")
If East<>vEast Or North<>vNorth
vEast=East
vNorth=North
GlobeImage = DrawEarth_II()
Print MilliSecs()-zeit
EndIf
DrawImage GlobeImage,150,50
PaintMeridians
Flip
Until AppTerminate()


Function DrawButton:Int(X:Int, Y:Int, State:Int, Text$)
SetColor 255,255,255
DrawRect X,Y,120, 40
DrawText Text, X,Y+20
If state=0
SetColor 55,55,55
Else
SetColor 55,111,55
EndIf
DrawRect X+2,Y+2,116, 36
SetColor 255,255,255
DrawText Text, X+45,Y+15
If MouseDown(1)>0
If MouseX()>X And MouseX()<X+120
If  MouseY()>Y And MouseY()<Y+40
State=1-State
Repeat
Until MouseDown(1)=0
EndIf
EndIf
EndIf

Return State
End Function



Function DrawSlider:Double(X:Int, Y:Int, Val:Double, F:Double, Text$)
SetColor 255,255,255
DrawRect X+20,Y,10, 360
DrawText Text, X,Y-20
DrawText Int(Val), X, Y+370
SetColor 55,85,85
DrawRect X+21,Y+1,8, 358
val = Slider(x,y,val*f+180)

SetColor 222,222,222
DrawRect X+5,Y+val-7,40,17
SetColor 1,1,1
DrawRect X+6,Y+val-6,39,17
SetColor 111,111,111
DrawRect X+6,Y+val-6,39,16
SetColor 55,111,111
DrawRect X+7,Y+val-5,36,13
Return (val-180)/f
End Function


Function Slider:Double(X:Int, Y:Int, Val:Double)
If MouseDown(1)>0
If MouseX()>X And MouseX()<X+50
Local mY:Int = MouseY()
If  mY>Y And  mY<Y+360
Val= mY-Y
EndIf
EndIf
EndIf
Return val
End Function


Function DrawCircle()
'draws a background circle
SetColor 255,255,255
SeedRnd 12345
For Local i%=0 To 1000
Local r:Double=Rnd(0,Rnd(3))
DrawOval Rand(ScreenMidX*2),Rand(ScreenMidY*2),r,r
Next
SetColor 111,222,222
DrawOval ScreenMidX-GlobeRADIUS-2,ScreenMidY-GlobeRADIUS-2,GlobeRADIUS*2+4,GlobeRADIUS*2+4
SetColor 1,1,66
DrawOval ScreenMidX-GlobeRADIUS,ScreenMidY-GlobeRADIUS,GlobeRADIUS*2,GlobeRADIUS*2
SetColor 255,255,255
End Function



Function DrawEarth_II:TImage()
countChecks=0

Local Globe:TImage=CreateImage(600,600)
Local PixMap:TPixmap = globe.Lock(0,False, True)
PixMap.ClearPixels 0

For Local j:Double = 0 To 3600 Step 3
Local xb:Double = (j*0.3 + 2*Width) Mod Width

For Local land:TLand = EachIn area[xb].List
Local i:Double = land.from
Repeat
i=i-3
Local yb:Double = (900-i)*0.3
Local Pixel:Int = Map.ReadPixel(xb,yb)
If (Pixel & $FFFFFF) = 0 Then Continue
Local Result:SResult = GreatCircle (j, i, East, North)
If Result.dist <90*FACTOR
countChecks=countChecks+1
Local x:Double  = RADIUS * Sin(Result.dist/FACTOR)
Local x1:Int = GlobeRADIUS +Sin(Result.tc)*x*GlobeRADIUS
Local y1:Int = GlobeRADIUS - Cos(Result.tc)*x*GlobeRADIUS
PixMap.WritePixel x1,y1,Pixel
PixMap.WritePixel x1+1,y1,Pixel
PixMap.WritePixel x1,y1+1,Pixel
PixMap.WritePixel x1+1,y1+1,Pixel
EndIf

Until i<land.Upto
Next
Next
Print "Count" + countchecks
UnlockImage Globe
Return Globe
End Function


Function PaintMeridians()
If GridOn=False Then Return
' paints the all meridians with 10° distance 
PaintNorthSouth
PaintEastWest
End Function


Function PaintNorthSouth()
For Local j:Int = -900 To 900 Step 150
For Local i:Int = 0 To 3600 Step 10
Local Result:SResult = GreatCircle (i, j, East, North)
PaintDot Result,i,j
Next
DrawDegree 1800, j, False
Next
End Function



Function DrawDegree(i:Int, j:Int, Equator:Int)
Local Result:SResult = GreatCircle (i, j, East, North)
Local x:Double  = RADIUS * Sin(Result.dist/FACTOR)
If Result.dist <75*FACTOR
Local x1:Int = ScreenMidX + Sin(Result.tc)*x*GlobeRADIUS
Local y1:Int = ScreenMidY - Cos(Result.tc)*x*GlobeRADIUS
Local t$
If Equator=True
If i<0
i=i+1800
t = String((i+1800)/10)+"°"

ElseIf i=0
t="±180°"
Else
t= String((i-1800)/10)+"°"
EndIf
Else
t=String(j/10)+"°"
EndIf
SetColor 255,255,255
DrawText t, x1-TextWidth(t)/2, y1
EndIf
End Function


Function PaintEastWest()
For Local j:Int = -1800 To 1800 Step 150
For Local i:Int = -900 To 900 Step 10
Local Result:SResult = GreatCircle (j, i, East, North)
PaintDot Result,i,j
Next
DrawDegree   j, 0, True
'now 10 lines like in PaintNorthSouth()
' what are they good for: ???
Next
End Function


Function PaintDot(Result:SResult, i:Int, j:Int)
'paint one pixel of the meridians:
Local x:Double  = RADIUS * Sin(Result.dist/FACTOR)
If Result.dist <90*FACTOR
Local x1:Int = ScreenMidX + Sin(Result.tc)*x*GlobeRADIUS
Local y1:Int = ScreenMidY - Cos(Result.tc)*x*GlobeRADIUS
DrawRect x1, y1, 1,1
EndIf
End Function


'==================================================================================
' T H E   K E R N E L   F U N C T I O N :
'==================================================================================

Type TResult
Field Dist:Double, Tc:Double
End Type


Function GreatCircle:SResult(E:Int, N:Int, EastM:Int, NorthM:Int)
E = (E+3600) Mod 3600
N = (N+3600)  Mod 3600
Local g2:Double = COSIN[N]
Local g3:Double = SINUS[N]

Local EE:Int=(E-EastM+3600) Mod 3600

Local g4:Double = g2 * COSIN[EE]
Local g5:Double = g2 * SINUS[EE]

Local g6:Double = Sqr(g3^2 + g4^2)

Local g7:Double = NorthM/10.0 + ATan2(g4, g3)

Local GG:Int = (g7*10 + 36000 ) Mod 3600
    Local g8:Double = g6 * COSIN[GG]
    Local g9:Double = g6 * SINUS[GG]
   
Local g10:Double = Sqr(g8^2 + g5^2)
   
Local loc:SResult
loc.dist = 90-ATan2(g9, g10)
loc.tc = ATan2(g5, g8)
Return loc
End Function


Type TLand
Field From:Int, Upto:Int
End Type


Type TArea
Field List:TList = New TList
End Type



Function FillAreas()
For Local x:Int=0 Until width
Area[x] = New TArea
Local From:Int=0
For Local y:Int=0 Until Height
Local Pixel:Int = Map.ReadPixel(x,y) & $FFFFFF
If Pixel=0
If From<>0
Local loc:TLand=New TLand
loc.From = 900 - From*10/3
loc.Upto = 900 -    Y*10/3
Area[x].List.AddLast loc
'Print "Found line" + x + " area from " + loc.from + "  to " +loc.upto
From=0
EndIf
Else
If From=0
From=y
EndIf
EndIf
Next
If From>0
Local loc:TLand=New TLand
loc.From = 900-From*10/3
loc.Upto = -899
Area[x].List.AddLast loc
'Print "Found line" + x + " area from " + loc.from + "  to " + loc.upto
From=0
EndIf
Next
End Function


Struct SResult
Field Dist:Double, Tc:Double
End Struct




Function PreSinus()
For Local i%=0 Until 7200
SINUS[i] = Sin(i/10.0)
COSIN[i] = Cos(i/10.0)
Next
End Function

Only half of the numbers at the equator are in order, to fix that, please delete line 194:   i=i+1800    :-)

To fix the problem with the number under the left slider (f=1)
I replaced line 80 with these two lines:

            If f=1 DrawText Int((Val+360)Mod 360-180)+"°", X+10, Y+370
            If f=2 DrawText Int(Val)+"°", X+10, Y+370

The right slider (f=2) gets no change.   :-)

I put the map inside the EXE-file with inkbin (Line 2 and 13)
and added a little red cross in the center, belonging to the coordinates under the sliders.
(Line 164 to 167)

So here is the full version! Thanks to Midimaster!!

The little red cross should look like this:

         For Local j:Int = 0 To 6
            PixMap.WritePixel GlobeRADIUS-3+j,GlobeRADIUS,$ffff00ff
            PixMap.WritePixel GlobeRADIUS,GlobeRADIUS-3+j,$ffff00ff           
         Next
   

A new version with 4 sliders!
Now you can change the size of the globe = zooming, and the projection: (Normally only 50% of the sphere is seen.)

To avoid the cpu-usage if nothing is changed, I use a lot of flipping, (if no mousebutton is pressed.)
(Now the program uses 0.1% CPU when calm.)
So for a still picture, the visible screen and the working screen must be identical,
this means you have to wait a bit after every change of the globe.

My sliders range ist not perfectly fitting, but I hope you still have a little fun!
And don't forget to have this little map in the same directory as the program!

Bye Kay


    SuperStrict
    ' MapToGlobe050.bmx Version 0.50 scalable zoom, try...
    ' turns a world map into a globe display
    ' movable thanks to Midimaster and Derron  :-)
    ' free example map from "https://asterweb.jpl.nasa.gov/gdem.asp", in this case quartered.
     
    Global GlobeRadius:Int=260
 
AppTitle = "Map to Globe 0.50        (made with BlitzMax)"

    Global ScreenMidY:Int=50+GlobeRadius
    Global ScreenMidX:Int=150+GlobeRadius
    Graphics ScreenMidX*2,ScreenMidY*2
    Global Map:TPixmap = LoadPixmap("GDEM-40km-color.png")
    Global Width:Int  = Map.Width
    Global Height:Int = Map.Height
    Print "height=" + Height
    Global East:Double    =  11.07 -180  'default coordinates: Nürnberg
    Global North:Double   =  49.45
  ' Global Radius:Double  =   1 '(Working with GlobeRadius for zoom)
    Global Factor: Double =   1  '(2 = worldmap Projection)

Global mouseDownOn:Int
Global mouseDownX:Int
Global mouseDownY:Int
Global mouseDownEast:Double
Global mouseDownNorth:Double

'_____ fill both screens ______
    East  = DrawSlider(20,100, East, 1,"East")
    North = DrawSlider(80,100, North, 2,"North")
Factor= Drawslider(GraphicsWidth()-130,100,Factor,50,"Proj.")
GlobeRadius= Drawslider(GraphicsWidth()-70,100,GlobeRadius,0.5,"Zoom")
    DrawCircle
    DrawEarth
    PaintMeridians
    Flip
    'Cls
    East  = DrawSlider(20,100, East, 1,"East")
    North = DrawSlider(80,100, North, 2,"North")
Factor= Drawslider(GraphicsWidth()-130,100,Factor,50,"Proj.")
GlobeRadius= Drawslider(GraphicsWidth()-70,100,GlobeRadius,0.5,"Zoom")
    DrawCircle
    DrawEarth
    PaintMeridians
    Flip
'_______________________________

Repeat

If MouseDown(1)
Cls
                Local zeit%=MilliSecs()
East  = DrawSlider(20,100, East, 1,"East")
North = DrawSlider(80,100, North, 2,"North")
Factor= Drawslider(GraphicsWidth()-130,100,Factor,50,"Proj.")
GlobeRadius= Drawslider(GraphicsWidth()-70,100,GlobeRadius,0.5,"Zoom")
                DrawCircle
                DrawEarth
                If GlobeRadius >= 250 PaintMeridians
               
       If MouseX() > 130 And MouseX() < GraphicsWidth() - 130
                                        If Not mouseDownOn
                                                mouseDownEast = East
                                                mouseDownNorth = North
                                                mouseDownX = MouseX()
                                                mouseDownY = MouseY()
                                                mouseDownOn = True
                                        Else
                                                East = mouseDownEast - (MouseX()-mouseDownX)*factor/4
If east < -180 Then east = east+360
If east > 180 Then east = east-360
                                                North = mouseDownNorth + (MouseY()-mouseDownY)*factor/4
If north < -90 Then north = -90
If north > 90 Then north =90
                                        EndIf
                                EndIf
                Print MilliSecs()-zeit

Else
                mouseDownOn = False
EndIf

Flip
    Until AppTerminate()
     
     
    Function DrawSlider:Double(X:Int, Y:Int, Val:Double, F:Double, Text$)
            SetColor 255,255,255
            DrawRect X,Y,50, 360
            DrawText Text, X,Y-20
           ' DrawText Int(Val), X, Y+370
            If f=1 DrawText Int((Val+360)Mod 360-180), X+10, Y+370
            If f=2 Or F=0.5 DrawText Int(Val), X+10, Y+370
            If f=50 DrawText Int(Val*50)+"%", X+10, Y+370
            SetColor 1,1,1
            DrawRect X+1,Y+1,48, 358

            val = Slider(x,y,val*f+180)
            SetColor 255,255,255
            DrawRect X+2,Float(Y+val),46,3
            Return (val-180)/f
    End Function
     
     
    Function Slider:Double(X:Int, Y:Int, Val:Double)
            If MouseDown(1)>0
                    If MouseX()>X And MouseX()<X+50
                            Local mY:Int = MouseY()
                            If  mY>Y And  mY<Y+360
                                    Val= mY-Y
                            EndIf
                    EndIf
            EndIf
            Return val     
    End Function
     
     
    Function DrawCircle()
            'draws a background circle
            DrawOval ScreenMidX-GlobeRadius-2,ScreenMidY-GlobeRadius-2,GlobeRadius*2+4,GlobeRadius*2+4
            SetColor 0,0,127
            DrawOval ScreenMidX-GlobeRadius,ScreenMidY-GlobeRadius,GlobeRadius*2,GlobeRadius*2
            SetColor 127,127,255
    End Function
     
     
     
    Function DrawEarth()
            For Local j:Double = -180 To 180 Step 0.33333333
                    Local xb:Double = (j*3 + 2*Width) Mod Width
                                   
                    For Local i:Double = -89.9 To 90 Step 0.3333333
                            Local yb:Double = (90-i)*3
                            Local Pixel:Int = Map.ReadPixel(Int(xb),Int(yb))         
                            If (Pixel & $FFFFFF) = 0 Then Continue
                            Pixel = Pixel & $FFFFFF
                            Local Result:TResult = GreatCircle (j, i, East, North)
                            If Result.dist <90*Factor
                                    Local x:Double  = Sin(Result.dist/Factor)
                                    Local x1:Int = ScreenMidX + Sin(Result.tc)*x*GlobeRadius
                                    Local y1:Int = ScreenMidY - Cos(Result.tc)*x*GlobeRadius                               
                                    Color Pixel
                                    DrawRect x1 , y1, Float(3/Sqr(factor)), Float(3/Sqr(factor))
                            EndIf
                    Next
            Next

'_________________ red Center-Cross ____________________
SetColor 255,0,0
DrawLine ScreenMidX-3,ScreenMidY,ScreenMidX+3,ScreenMidY
DrawLine ScreenMidX,ScreenMidY-3,ScreenMidX,ScreenMidY+3

    End Function
     
     
    Function Color(Pixel:Int)
            Local r:Int = pixel Shr 16
            Local g:Int = (pixel & $FF00) Shr 8
            Local b:Int = (Pixel & $FF)
            SetColor r,g,b
    End Function
     
     
    Function PaintMeridians()
            ' paints the all meridians with 15° distance 
            PaintNorthSouth
            PaintEastWest
    End Function
     
     
    Function PaintNorthSouth()
            For Local j:Int = -90 To 90 Step 15
                    For Local i:Int = 0 To 360
                            Local Result:TResult = GreatCircle (i, j, East, North)
                            PaintDot Result
                    Next
            Next
    End Function
     
     
    Function PaintEastWest()
            For Local j:Int = -180 To 180 Step 15
                    For Local i:Int = -90 To 90
                            Local Result:TResult = GreatCircle (j, i, East, North)
                            PaintDot Result
                    Next
                   
            Next
    End Function
     
     
    Function PaintDot(Result:TResult)
            'paint one pixel of the meridians:     
            Local x:Double  = Sin(Result.dist/Factor)
            If Result.dist <90*Factor
                    Local x1:Int = ScreenMidX + Sin(Result.tc)*x*GlobeRadius
                    Local y1:Int = ScreenMidY - Cos(Result.tc)*x*GlobeRadius
SetColor(255,255,255)
                    DrawRect x1, y1, 1,1
            EndIf
    End Function
     
     
    '==================================================================================
    '       T H E   K E R N E L   F U N C T I O N :
    '==================================================================================
     
    Type TResult
            Field Dist:Double, Tc:Double
    End Type
     
     
    Function GreatCircle:TResult(E:Double, N:Double, EastM:Double, NorthM:Double)
            Local h:Double = Pi / 180.0
            Local g2:Double = Cos(N)
            Local g3:Double = Sin(N)
     
            Local g4:Double = g2 * Cos((E-EastM))
            Local g5:Double = g2 * Sin((E-EastM))
     
            Local g6:Double = Sqr(g3^2 + g4^2)
     
            Local g7:Double = NorthM + ATan2(g4, g3)
     
        Local g8:Double = g6 * Cos(g7)
        Local g9:Double = g6 * Sin(g7)
       
            Local g10:Double = Sqr(g8^2 + g5^2)
       
            Local loc:TResult=New TResult
           
            loc.dist = 90-ATan2(g9, g10)
            loc.tc = ATan2(g5, g8)
            Return loc
    End Function