#! /usr/local/bin/xbigforth
\ automatic generated code
\ do not edit

also editor also minos also forth

component class galaxy
public:
  glcanvas ptr GLgalaxy
  canvas ptr a#
  hscaler ptr bulge#
  hscaler ptr spread#
  hscaler ptr spiral#
  info-menu ptr meas-string
  textfield ptr iterations
  button ptr iterate
  button ptr iterates
  button ptr iterates
 ( [varstart] ) cell var alphax
cell var alphay
cell var alphaz
cell var alphapitch
cell var alphabend
cell var alpharoll
cell var zoom
cell var disc#
cell var startex
cell var bulgep
cell var spreadp
cell var spiralp
cell var star-path
cell var filename
cell var do-mass
cell var don't
3 cells var galaxy-lock
method redraw-galaxy ( [varend] )
how:
  : params   DF[ 0 ]DF X" Galaxy" ;
class;

component class about
public:
  button ptr ok-button
 ( [varstart] )  ( [varend] )
how:
  : params   DF[ 0 ]DF X" About" ;
class;

component class measure-menu
public:
 ( [varstart] )  ( [varend] )
how:
  : params   DF[ 0 ]DF X" Measure" ;
class;

measure-menu implements
 ( [methodstart] )  ( [methodend] )
  : widget  ( [dumpstart] )
        ^^ S[ ^ galaxy with
    0 disc# ! redraw-galaxy s" None" meas-string assign
endwith ]S ( MINOS ) X" None" menu-entry new 
        ^^ S[ ^ galaxy with
    1 disc# ! redraw-galaxy s" New/Old" meas-string assign
endwith ]S ( MINOS ) X" New/Old" menu-entry new 
        ^^ S[ ^ galaxy with
    2 disc# ! redraw-galaxy s" Old" meas-string assign
endwith ]S ( MINOS ) X" Old" menu-entry new 
        ^^ S[ ^ galaxy with
    3 disc# ! redraw-galaxy s" New" meas-string assign
endwith ]S ( MINOS ) X" New" menu-entry new 
      #4 vabox new #2 borderbox
    ( [dumpend] ) ;
class;

about implements
 ( [methodstart] )  ( [methodend] )
  : widget  ( [dumpstart] )
          X" This program simulates 'dark masses' in a galaxy." text-label new 
          X" However, it doesn't assume real dark masses, but" text-label new 
          X" a generalization of Mach's principle." text-label new 
          X" The assumed formula for an inertial system is: sum(a*m/r²)=0." text-label new 
          X" Since the background mass is small compared to the galaxie's" text-label new 
          X" mass, most of the additional accelleration comes from the galaxy" text-label new 
          X" itself." text-label new 
            $10 $1 *hfil $10 $1 *vfil glue new 
             icon" icons/starsln" icon new 
            $10 $1 *hfil $10 $1 *vfil glue new 
          #3 habox new #1 vskips
        #8 vabox new
          $10 $1 *hfill $10 $1 *vfil rule new 
          ^^ S[ close ]S ( MINOS ) X" OK" button new  ^^bind ok-button
          $10 $1 *hfill $10 $1 *vfil glue new 
        #3 habox new
      #2 vabox new panel
    ( [dumpend] ) ;
class;

include galaxy.fs
galaxy implements
 ( [methodstart] ) : redraw-galaxy  GLgalaxy render  GLgalaxy draw ;
: make-galaxy  don't @ ?EXIT
  bulgep @ spreadp @ spiralp @ set-masses glgalaxy draw
  ( mass# draw a# draw ) redraw-galaxy 1 do-mass ! ;
: draw-galaxy
  startex @ 0= IF
      1 3d-turtle textures dup startex ! 
      3d-turtle set-texture
      S" icons/starsln" 3d-turtle load-texture
  THEN
  GLgalaxy self
  alphax @ alphay @ alphaz @
  alphapitch @ alphabend @ alpharoll @ zoom @ disc# @
  galaxy-draw ;
: iterate-step  ^ 1 $10000 dup NewTask pass op!
  galaxy-lock lock
  do-mass @ 1 = IF  set-msum ( mass# draw ) set-a a# draw  THEN
  do-mass off set-a+ a# draw redraw-galaxy dpy sync
  galaxy-lock unlock ;
: iterate-disc  ^ 1 $10000 dup NewTask pass op!
  galaxy-lock lock
  disc-msum disc-a disc-a+ redraw-galaxy dpy sync
  galaxy-lock unlock ; ( [methodend] )
  : widget  ( [dumpstart] )
              GL[ outer with draw-galaxy endwith ]GL ( MINOS ) ^^ CK[ 2drop 2drop ]CK ( MINOS ) $200 $1 *hfil $200 $1 *vfil glcanvas new  ^^bind GLgalaxy
            #1 habox new
                    clipper new  D[ 
                      CV[ draw-scala a-pos @ >r
decimal
visualize-v  r@ vis@ 
visualize-v+ r@ vis@ swap
dup 0= IF  nip  ELSE  #1000 swap */  THEN
0 <# # # # '. hold #s #>
r@ 1+ $600 home! r@ 2* vismax > IF  2 ELSE  0  THEN  0 textpos text
visualize-a  r@ vis@ 
visualize-a+ r@ vis@ swap
dup 0= IF  nip  ELSE  #1000 swap */  THEN
0 <# # # # '. hold #s #>
r@ 1+ 0 home! r> 2* vismax > IF  2 ELSE  0  THEN  0 textpos text
path 0 vismax -$100 * to stroke ]CV ( MINOS ) ^^ CK[ nip 1 and IF  DOPRESS  2swap 2drop  THEN
drop
a# xywh drop >r drop - r> vismax swap */
0 max vismax 1- min a-pos !
a# draw ]CK ( MINOS ) $20 $1 *hfil $100 $1 *vfil canvas new  ^^bind a#
                    #1 habox new ]D ( MINOS ) 
                        ^^ #0 #360 SC[ #360 mod alphapitch ! redraw-galaxy ]SC ( MINOS )  TT" Pitch" hscaler new  #-180 SC# 
                        ^^ #0 #360 SC[ #360 mod alphabend ! redraw-galaxy ]SC ( MINOS )  TT" Bend" hscaler new  #-180 SC# 
                        ^^ #0 #360 SC[ #360 mod alpharoll ! redraw-galaxy ]SC ( MINOS )  TT" Roll" hscaler new  #-180 SC# 
                      #3 vabox new vfixbox  #2 borderbox
                        ^^ #0 #360 SC[ #360 mod alphax ! redraw-galaxy ]SC ( MINOS )  TT" Rotate around X axis" hscaler new  #-180 SC# 
                        ^^ #0 #360 SC[ #360 mod alphay ! redraw-galaxy ]SC ( MINOS )  TT" Rotate around Y axis" hscaler new  #-180 SC# 
                        ^^ #0 #360 SC[ #360 mod alphaz ! redraw-galaxy ]SC ( MINOS )  TT" Rotate around Z axis" hscaler new  #-180 SC# 
                      #3 vabox new vfixbox  #2 borderbox
                    #2 habox new
                  #2 vabox new vfixbox 
                    ^^ #1000 #1000 SC[ ( pos -- ) zoom ! redraw-galaxy ]SC ( MINOS )  TT" Zoom factor in %" vscaler new 
                    ^^ #5 #10 SC[ ( pos -- ) .1e fm* f>fs .black2 3 cells + !
redraw-galaxy ]SC ( MINOS )  TT" Background intensity" hscaler new 
                  #2 vabox new #2 borderbox
                #2 habox new
                      ^^ #60 #500 SC[ .01e fm* 3.8e f* f**2 1/f msum+ f! ]SC ( MINOS )  TT" Background radius relative to galaxy radius in percent" hscaler new 
                      ^^ #33 #100 SC[ bulgep ! make-galaxy ]SC ( MINOS )  TT" Bulge in percent" hscaler new  ^^bind bulge#
                    #2 vabox new
                      ^^ #25 #100 SC[ spreadp ! make-galaxy ]SC ( MINOS )  TT" Spread of the arms" hscaler new  ^^bind spread#
                      ^^ #100 #500 SC[ spiralp ! make-galaxy ]SC ( MINOS )  TT" Spiral factor" hscaler new  ^^bind spiral#
                    #2 vabox new
                  #2 habox new
                        ^^ -1 T[ spiral-dist on make-galaxy ][ ( MINOS ) spiral-dist off make-galaxy ]T ( MINOS ) X" dist" tbutton new 
                        ^^ -1 T[ dirsens on a# draw redraw-galaxy ][ ( MINOS ) dirsens off a# draw redraw-galaxy ]T ( MINOS )  TT" On: Show a only in direction to center" X" ->r" tbutton new 
                        M: measure-menu menu X" " info-menu new  ^^bind meas-string
                      #3 habox new hfixbox  vfixbox  #2 borderbox
                      $0 $1 *hfil $0 $1 *vfil glue new 
                        ^^ #5 #10 SC[ $100 swap << to star# make-galaxy ]SC ( MINOS )  TT" 2^(9+n) stars" hscaler new 
                          $0 $1 *hfil $0 $1 *vfil glue new 
                          #10. ]N ( MINOS ) ^^ SN[  ]SN ( MINOS ) textfield new  ^^bind iterations
                          $0 $1 *hfil $0 $1 *vfil glue new 
                        #3 vabox new hfixbox  #1 hskips
                      #2 habox new vfixbox 
                    #3 vabox new hfixbox 
                  #1 vabox new hfixbox  #2 vskips
                #2 habox new #2 borderbox
              #2 vabox new vfixbox 
            #1 habox new #-2 borderbox
                ^^ S[ s" Load Stars" s" " star-path @
IF  star-path $@  ELSE  s" *.star"  THEN
^ S[ 2swap star-path $! filename $!
     star-path $@ filename $@ path+file r/o open-file throw >r
     & star# cell r@ read-file throw drop init-stars
     bulgep 2 cells r@ read-file throw drop  don't on
     bulgep @ 0 bulge# assign
     spreadp @ 0 spread# assign  don't off
     stars $@ r@ read-file throw drop r> close-file throw
     a# draw redraw-galaxy 2drop ]S
fsel-action ]S ( MINOS )  icon" icons/load" icon-but new 
                ^^ S[ s" Save Stars" s" " star-path @
IF  star-path $@  ELSE  s" *.star"  THEN
^ S[ 2swap star-path $! filename $!
     star-path $@ filename $@ path+file r/w create-file throw
     >r & star# cell r@ write-file throw
     bulgep 2 cells r@ write-file throw
     stars $@ r@ write-file throw r> close-file throw ]S
fsel-action ]S ( MINOS )  icon" icons/save" icon-but new 
              #2 hatbox new vfixbox 
              ^^ S[ iterate-step ]S ( MINOS ) X" Run" button new  ^^bind iterate
              ^^ S[ iterations get drop 0 DO iterate-step LOOP write-csv ]S ( MINOS ) X" Runs" button new  ^^bind iterates
              ^^ S[ iterate-disc ]S ( MINOS ) X" Disc" button new  ^^bind iterates
              ^^ S[ close ]S ( MINOS ) X" Close" button new 
              ^^ S[ about open ]S ( MINOS ) X" About" button new 
            #6 hatbox new vfixbox  panel #-2 borderbox
          #3 vabox new
        #1 vabox new
      #1 vabox new
    ( [dumpend] ) ;
class;

: main
  galaxy open-app
  event-loop bye ;
script? [IF]  main  [THEN]
previous previous previous
