stars.lst

$M 128000 $S> $F< $P< $%0 $*% $O3 $A2 $E$
'
REM #KEY ColdFire v4e|Classic 68K
REM #IFK 0
REM #BRK MA
REM #EIK 1 ! ColdFire v4e
REM #LIB ColdFire
REM #EXT prx
REM #EIK 2 ! Classic 68K
REM #LIB 68000
REM #EXT prg
REM #FIK
'
IF FATAL
  ~FORM_ALERT(1,"[1][ This version is not suited | for this CPU. Please get | the correct archive. ][ Ok ]")
  @leave
ENDIF
IF ERR=8
  ~FORM_ALERT(1,"[1][ Insuffisant or fragmented | memory ][ Ok ]")
  @leave
ELSE
  init1
  init2
  main
ENDIF
'
> PROCEDURE leave
  @restore_colors
  @close_win
  @mxfree(palette%)
  IF ressource!
    ~MENU_BAR(ressource_menu%,0)
    ~RSRC_FREE()
  ENDIF
  QUIT
RETURN
'
> PROCEDURE init1
  '
  IF A~I<0 ! appl_init() failed?
    @leave
  ENDIF
  '
  IF _B=0
    ~FORM_ALERT(1,"[1][ AES not initialized ][ Quit ]")
    @leave
  ENDIF
  '
  mx_mask%=@mx_mask
  mxalloc!=(_GEMDOS>=&H19)
  '
  magic!=GETCOOKIE(CVL("MagX"))
  mint!=(_MINT<>0) ! GETCOOKIE(CVL("MiNT"))
  '
  IF magic! OR mint!
    naes!=TRUE
  ELSE IF _AES>=&H399
    naes!=TRUE
  ELSE
    naes!=FALSE
  ENDIF
  '
  multi!=MULTITASK?
  '
  @declare
  @declare_effect
  IF mint!=FALSE
    RESERVE 32000
  ENDIF
  @allocate
  '
  ~RSRC_FREE()
  IF EXIST(ressource_file$)
    IF RSRC_LOAD(ressource_file$)<>0
      ~RSRC_GADDR(0,0,ressource_menu%)
      ressource!=TRUE
    ENDIF
  ENDIF
  '
RETURN
> PROCEDURE declare
  general_path$=CURDIR$
  '
  ressource_file$=general_path$+"STARS.RSC"
  ressource!=FALSE
  ressource_menu%=0
  '
  preferences_file$=general_path$+"VDI_FX.INF"
  '
  DIM boolean$(2)
  boolean$(0)="FALSE"
  boolean$(1)="TRUE"
  '
  hand_win&=0
  xd&=0
  yd&=0
  ld&=0
  hd&=0
  wx&=_DX
  wy&=_DY
  wl&=_DW
  wh&=_DH
  win!=FALSE
  aff!=FALSE
  '
RETURN
> PROCEDURE allocate
  '
  palette%=@mxalloc(1536,3)
  '
RETURN
> PROCEDURE init2
  '
  ~VSF_INTERIOR(1)
  ~VSF_STYLE(0)
  ~VSF_COLOR(1)
  ~VSF_PERIMETER(0)
  @save_colors
  @set_colors
  '
  IF ressource!
    ~MENU_IENABLE(ressource_menu%,3,0)
    ~MENU_BAR(ressource_menu%,1)
  ENDIF
  IF multi!=FALSE
    ~FORM_DIAL(3,0,0,0,0,_DX,_DY,_DW,_DH)
  ENDIF
  '
RETURN
'
> PROCEDURE declare_effect
  LOCAL pref_len%
  '
  IF EXIST(preferences_file$)
    '
    mem_pos%=0
    '
    file_handle&=FOPEN(preferences_file$,0)
    IF file_handle&>0
      '
      pref_len%=FSEEK(0,file_handle&,2)
      ~FSEEK(0,file_handle&,0)
      '
      IF pref_len%>0
        mem_pos%=@mem_init(pref_len%)
        '
        IF mem_pos%>0
          IF FREAD(file_handle&,pref_len%,mem_pos%)<>pref_len%
            mem_pos%=@mem_close
          ENDIF
        ENDIF
      ENDIF
      ~FCLOSE(file_handle&)
    ENDIF
    '
    IF mem_pos%>0
      '
      mem_start_ptr%=mem_pos%
      mem_end_ptr%=ADD(mem_pos%,pref_len%)
      DO
        IF BYTE{mem_start_ptr%}=13 OR BYTE{mem_start_ptr%}=10
          BYTE{mem_start_ptr%}=0
        ENDIF
        INC mem_start_ptr%
      LOOP UNTIL mem_start_ptr%>mem_end_ptr%
      mem_start_ptr%=mem_pos%
      '
      star_nb&=VAL(@mem_find$("STARS_NUMBER"))
      star_speed&=VAL(@mem_find$("STARS_SPEED"))
      '
    ENDIF
    '
    ~@mem_close
    '
  ELSE
    '
    star_nb&=60
    star_speed&=20
    '
  ENDIF
  '
  star_nb&=MAX(10,MIN(star_nb&,6000))
  star_speed&=MAX(1,MIN(star_speed&,500))
  '
  DIM star_x&(star_nb&),star_y&(star_nb&),star_z&(star_nb&)
  DIM p_old_x&(star_nb&),p_old_y&(star_nb&)
  '
RETURN
'
> FUNCTION mem_init(mem_wished_len%)
  $F%
  ~@mem_close
  mem_len%=MAX(16000,SHL(SHR(ADD(mem_wished_len%,31),4),4))
  mem_start_adr%=@mxalloc(mem_len%,3)
  IF mem_start_adr%<0
    ' alert ?
    mem_start_adr%=0
  ENDIF
  RETURN mem_start_adr%
ENDFUNC
> FUNCTION mem_close
  $F%
  IF mem_start_adr%>0
    @mxfree(mem_start_adr%)
    mem_start_adr%=0
    mem_len%=0
  ENDIF
  RETURN 0
ENDFUNC
> FUNCTION mem_find$(mem_key$)
  LOCAL mem_find_line$,mem_find_ptr%
  IF mem_start_ptr%>0 AND mem_end_ptr%>mem_start_ptr%
    mem_find_ptr%=mem_start_ptr%
    DO
      mem_find_line$=CHAR{mem_find_ptr%}
      ADD mem_find_ptr%,SUCC(LEN(mem_find_line$))
      '
      IF INSTR(mem_find_line$,mem_key$+"=")=1
        mem_str$=MID$(mem_find_line$,ADD(LEN(mem_key$),2))
        mem_pos&=INSTR(mem_str$,"#")
        IF mem_pos&>0
          RETURN TRIM$(LEFT$(mem_str$,PRED(mem_pos&)))
        ENDIF
        RETURN TRIM$(mem_str$)
      ENDIF
      '
    LOOP UNTIL mem_find_ptr%>=mem_end_ptr%
  ENDIF
  RETURN ""
ENDFUNC
> FUNCTION mem_get_flag(find_str$,default_flag!)
  $F%
  '
  IF @mem_find$(find_str$)=boolean$(ABS(NOT default_flag!))
    RETURN NOT default_flag!
  ENDIF
  RETURN default_flag!
ENDFUNC
'
> PROCEDURE main
  @create_win
  @v_hide_c
  @clear_win
  ~VS_CLIP(1,xd&,yd&,ADD(xd&,PRED(ld&)),ADD(yd&,PRED(hd&)))
  exit!=FALSE
  DO
    draw_win
  LOOP UNTIL exit!
  ~VS_CLIP(0,xd&,yd&,ADD(xd&,PRED(ld&)),ADD(yd&,PRED(hd&)))
  @v_show_c
  @leave
RETURN
'
> PROCEDURE create_win
  hand_win&=WIND_CREATE(&H0,30,30,30,30)
  IF hand_win&>0
    wx&=_DX
    wy&=_DY
    wl&=_DW
    wh&=_DH
    win!=TRUE
    IF WIND_OPEN(hand_win&,wx&,wy&,wl&,wh&)=0
      ~FORM_ALERT(1,"[1][ Can't open window ][ Quit ]")
      leave
    ELSE
      ~WIND_GET(hand_win&,4,xd&,yd&,ld&,hd&)
      xd2&=ADD(xd&,PRED(ld&))
      yd2&=ADD(yd&,PRED(hd&))
      ld2&=DIV(ld&,2)
      hd2&=DIV(hd&,2)
    ENDIF
  ELSE
    ~FORM_ALERT(1,"[1][ No window available ][ Quit ]")
    leave
  ENDIF
  aff!=win!
RETURN
> PROCEDURE close_win
  IF win!
    ~WIND_CLOSE(hand_win&)
    ~WIND_DELETE(hand_win&)
    win!=FALSE
    aff!=FALSE
  ENDIF
RETURN
> PROCEDURE clear_win
  ~VSF_COLOR(1)
  ~VS_CLIP(1,xd&,yd&,ADD(xd&,PRED(ld&)),ADD(yd&,PRED(hd&)))
  ~V_BAR(xd&,yd&,ADD(xd&,PRED(ld&)),ADD(yd&,PRED(hd&)))
  ~VS_CLIP(0,xd&,yd&,ADD(xd&,PRED(ld&)),ADD(yd&,PRED(hd&)))
RETURN
> PROCEDURE draw_win
  '
  FOR n&=1 TO star_nb&
    '
    IF star_z&(n&)<1
      star_y&(n&)=@new_value
      star_x&(n&)=@new_value
      star_z&(n&)=4032
    ELSE
      @v_point(1,p_old_x&(n&),p_old_y&(n&))
      '
      p_y&=@to_2d(star_y&(n&),star_z&(n&),hd2&)
      IF p_y&<yd& OR p_y&>yd2&
        star_z&(n&)=0
      ELSE
        p_old_y&(n&)=p_y&
        p_x&=@to_2d(star_x&(n&),star_z&(n&),ld2&)
        IF p_x&<xd& OR p_x&>xd2&
          star_z&(n&)=0
        ELSE
          p_old_x&(n&)=p_x&
          @v_point(@to_color(star_z&(n&)),p_x&,p_y&)
          SUB star_z&(n&),star_speed&
        ENDIF
      ENDIF
    ENDIF
    ~GRAF_MKSTATE(gm_x&,gm_y&,gm_s&,gk_s&)
    IF BCONSTAT(2) OR gm_s&>0 OR gk_s&>0
      exit!=TRUE
    ENDIF
    EXIT IF exit!
  NEXT n&
  '
RETURN
'
> FUNCTION new_value
  $F%
  RETURN SHL&(SUB(RND*400,200),4)
ENDFUNC
> FUNCTION to_2d(vp&,vz&,vd&)
  $F%
  RETURN ADD(DIV(SHL(vp&,8),vz&),vd&)
ENDFUNC
> FUNCTION to_color(vz&)
  $F%
  IF _B>4
    RETURN ADD(SHR&(vz&,6),15)
  ELSE IF _B=4
    RETURN MAX(2,MIN(SHR&(vz&,8),15))
  ENDIF
  RETURN 0
ENDFUNC
'
> PROCEDURE restore_colors
  LOCAL tmp_c&,tmp_d&,col_r&,col_g&,col_b&
  '
  IF palette%>0
    FOR tmp_c&=0 TO 255
      tmp_d&=MUL(tmp_c&,6)
      col_r&=INT{ADD(palette%,tmp_d&)}
      col_g&=INT{ADD(palette%,ADD(tmp_d&,2))}
      col_b&=INT{ADD(palette%,ADD(tmp_d&,4))}
      ~VS_COLOR(tmp_c&,col_r&,col_g&,col_b&)
    NEXT tmp_c&
  ENDIF
RETURN
> PROCEDURE save_colors
  LOCAL tmp_c&,tmp_d&,col_r&,col_g&,col_b&
  '
  IF palette%>0
    FOR tmp_c&=0 TO 255
      ~VQ_COLOR(tmp_c&,0,col_r&,col_g&,col_b&)
      tmp_d&=MUL(tmp_c&,6)
      INT{ADD(palette%,tmp_d&)}=col_r&
      INT{ADD(palette%,ADD(tmp_d&,2))}=col_g&
      INT{ADD(palette%,ADD(tmp_d&,4))}=col_b&
    NEXT tmp_c&
  ENDIF
RETURN
> PROCEDURE set_colors
  LOCAL tmp_n&,tmp_l&
  '
  IF _B>4
    FOR tmp_n&=1 TO 63
      tmp_l&=MUL(SUB(63,tmp_n&),15)
      ~VS_COLOR(ADD(15,tmp_n&),tmp_l&,tmp_l&,MIN(ADD(tmp_l&,40),1000))
    NEXT tmp_n&
  ELSE IF _B=4
    FOR tmp_n&=1 TO 14
      tmp_l&=MUL(SUB(15,tmp_n&),60)
      ~VS_COLOR(SUCC(tmp_n&),tmp_l&,tmp_l&,MIN(ADD(tmp_l&,40),1000))
    NEXT tmp_n&
  ENDIF
RETURN
'
> PROCEDURE v_hide_c
  IF naes!
    GHIDEM
  ELSE
    ~V_HIDE_C()
  ENDIF
RETURN
> PROCEDURE v_show_c
  IF naes!
    GSHOWM
  ELSE
    ~V_SHOW_C()
  ENDIF
RETURN
'
> PROCEDURE v_point(cc&,cx&,cy&)
  ~VSM_COLOR(cc&)
  '
  PTSIN(0)=cx&
  PTSIN(1)=cy&
  ~V_PMARKER(1)
RETURN
'
> FUNCTION mx_mask
  $F%
  IF MXALLOC(-1,0)=-32
    RETURN 0
  ELSE IF SYSCONF(-1)=-32
    RETURN 3
  ELSE
    RETURN -1
  ENDIF
ENDFUNC
> FUNCTION mxalloc(mxlen%,mxmode&)
  $F%
  IF mxalloc!
    RETURN MXALLOC(mxlen%,mxmode&)
  ENDIF
  RETURN MALLOC(mxlen%)
ENDFUNC
> PROCEDURE mxfree(mx_adr%)
  IF mx_adr%>0
    ~MFREE(mx_adr%)
  ENDIF
RETURN