landscap.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<8
    ~FORM_ALERT(1,"[1][ Need at least 256 colors ][ 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$+"LANDSCAP.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%
      '
      scape_random!=FALSE
      scape_type$=UPPER$(@mem_find$("SCAPE_TYPE"))
      IF scape_type$="LUNAR"
        scape_type&=1
      ELSE IF scape_type$="GRASS"
        scape_type&=2
      ELSE IF scape_type$="DESERT"
        scape_type&=3
      ELSE IF scape_type$="ICE"
        scape_type&=4
      ELSE
        scape_random!=TRUE
      ENDIF
      '
      scape_wait&=MAX(10,MIN(VAL(@mem_find$("SCAPE_DELAY")),60))
      '
      scape_level=MAX(2,MIN(VAL(@mem_find$("SCAPE_LEVEL")),10))
      '
    ENDIF
    '
    ~@mem_close
    '
  ELSE
    '
    scape_random!=TRUE
    scape_delay&=30
    scape_level&=3
    '
  ENDIF
  '
  DIM lz(_DW),lx(_DW),lc(_DW)
  '
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
  exit!=FALSE
  @clear_win
  DO
    @draw_win
    @clear_win
    @set_colors
  LOOP UNTIL exit!
  @v_show_c
  @leave
RETURN
'
> PROCEDURE create_win
  hand_win&=WIND_CREATE(&X0,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
  '
  ~VSF_INTERIOR(2)
  ~VSF_STYLE(8)
  '
  ~VS_CLIP(1,xd&,yd&,ADD(xd&,PRED(ld&)),ADD(yd&,PRED(hd&)))
  '
  FOR i&=0 TO 500
    px&=INT(ld&*RND)
    py&=INT(DIV(hd&,2)*RND)
    pcolor&=ADD(170,INT(40*RND))
    @v_point(pcolor&,px&,py&)
    IF BCONSTAT(2)
      exit!=TRUE
    ENDIF
    EXIT IF exit!
  NEXT i&
  '
  IF NOT exit!
    zx&=ADD(10,SUB(ld&,20)*RND)
    zy&=SUB(DIV(hd&,2),INT(DIV(SUB(hd&,10),2)*RND))
    '
    IF RND*100<30
      FOR i&=0 TO 60
        ~VSF_COLOR(SUB(230,i&))
        @v_bar_xywh(xd&,ADD(yd&,SUB(DIV(hd&,2),i&)),ld&,1)
      NEXT i&
      ~VSF_COLOR(230)
      @v_bar_xywh(xd&,ADD(yd&,PRED(DIV(hd&,2))),ld&,DIV(hd&,2))
    ELSE
      FOR i&=0 TO 60
        ~VSF_COLOR(ADD(170,i&))
        ~V_CIRCLE(ADD(xd&,zx&),ADD(yd&,zy&),SUB(DIV(_DH,4),i&))
        IF BCONSTAT(2)
          exit!=TRUE
        ENDIF
        EXIT IF exit!
      NEXT i&
    ENDIF
  ENDIF
  '
  IF NOT exit!
    lz(0)=0
    lx(0)=DIV(hd&,2)
    lc(0)=130
    ~VSF_COLOR(lc(0))
    @v_bar_xywh(ADD(xd&,lz(0)),ADD(yd&,lx(0)),1,1)
    ~VSF_COLOR(1)
    @v_bar_xywh(ADD(xd&,lz(0)),ADD(yd&,lx(0)+1),1,SUB(hd&,lx(0)+1))
    FOR i&=1 TO ld&
      lz(i&)=lz(PRED(i&))+1
      lx(i&)=lx(PRED(i&))-scape_level/2+scape_level*RND
      lc(i&)=lc(PRED(i&))-5+10*RND
      lc(i&)=MAX(100,MIN(lc(i&),160))
      ~VSF_COLOR(lc(i&))
      @v_bar_xywh(ADD(xd&,lz(i&)),ADD(yd&,lx(i&)),1,1)
      ~VSF_COLOR(1)
      @v_bar_xywh(ADD(xd&,lz(i&)),ADD(yd&,lx(i&)+1),1,SUB(hd&,lx(i&)+1))
    NEXT i&
  ENDIF
  '
  IF NOT exit!
    sz=1
    chk&=0
    REPEAT
      sz=sz*1.008
      lz(0)=-(sz-1)*(ld&/2)
      lx(0)=lx(0)+(sz*RND)
      FOR i&=1 TO ld&
        lz(i&)=lz(PRED(i&))+sz
        lx(i&)=lx(i&)-sz/4+sz*RND
        lx(i&)=MAX(lx(PRED(i&))-sz,MIN(lx(i&),lx(PRED(i&))+sz))
        '
        IF lz(i&)>=-1 AND lz(i&)<=ld&
          lc(i&)=lc(i&)-4+8*RND
          lc(i&)=MAX(lc(PRED(i&))-3,MIN(lc(i&),lc(PRED(i&))+3))
          lc(i&)=MAX(100,MIN(lc(i&),160))
          ~VSF_COLOR(lc(i&))
          @v_bar_xywh(xd&+lz(i&),yd&+lx(i&),sz+1,sz+1)
        ENDIF
        IF lx(i&)>hd&
          INC chk&
          EXIT IF chk&>ld&
        ENDIF
        ~GRAF_MKSTATE(gm_x&,gm_y&,gm_s&,gk_s&)
        IF BCONSTAT(2) OR gm_s&>0 OR gk_s&>0
          exit!=TRUE
          EXIT IF exit!
        ENDIF
      NEXT i&
    UNTIL exit! OR chk&>ld&
  ENDIF
  '
  ~VS_CLIP(0,xd&,yd&,ADD(xd&,PRED(ld&)),ADD(yd&,PRED(hd&)))
  '
  IF NOT exit!
    chk&=0
    DO
      ~EVNT_TIMER(240)
      INC chk&
      EXIT IF chk&>MUL(scape_wait&,4)
      ~GRAF_MKSTATE(gm_x&,gm_y&,gm_s&,gk_s&)
      IF BCONSTAT(2) OR gm_s&>0 OR gk_s&>0
        exit!=TRUE
        EXIT IF exit!
      ENDIF
    LOOP
  ENDIF
  '
RETURN
'
> 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
  '
  IF scape_random!
    scape_type&=MAX(1,MIN(SUCC(INT(RND*4)),4))
  ENDIF
  '
  ~VS_COLOR(0,1000,1000,1000)
  ~VS_COLOR(1,0,0,0)
  '
  pl&=0
  plg&=0
  FOR i&=100 TO 160
    pll&=CINT(pl&*0.67)
    IF pll&>60
      pll&=60
    ENDIF
    plg&=MUL(pl&,8)
    SELECT scape_type&
    CASE 1
      ~VS_COLOR(i&,0,0,plg&)
    CASE 2
      ~VS_COLOR(i&,0,plg&,0)
    CASE 3
      ~VS_COLOR(i&,plg&,MUL(pll&,8),0)
    DEFAULT
      ~VS_COLOR(i&,plg&,plg&,plg&)
    ENDSELECT
    INC pl&
  NEXT i&
  '
  pl&=0
  ee&=INT(RND*100)
  plh&=0
  FOR i&=170 TO 230
    pll&=MUL(pl&,2)
    IF pll&>60
      pll&=60
    ENDIF
    plg&=MUL(pl&,8)
    plh&=MUL(pll&,8)
    IF ee&<30
      ~VS_COLOR(i&,plh&,plg&,plg&)
    ELSE
      ~VS_COLOR(i&,plg&,plg&,plh&)
    ENDIF
    INC pl&
  NEXT i&
  '
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
> PROCEDURE v_bar_xywh(cx&,cy&,cw&,ch&)
  ~V_BAR(cx&,cy&,ADD(cx&,PRED(cw&)),ADD(cy&,PRED(ch&)))
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