src/func.mpsrc

   1 unit func;
   2
   3 interface
   4  function get_spawn_x:integer;//Возвращает блок по X где должен появиться игрок
   5  function get_spawn_y:integer;//Возвращает блок по Y где должен появиться игрок
   6  procedure draw_block(xx,yy:integer);
   7  procedure drawSmallItem(item, x, y:integer);
   8  procedure drawItem(item, sum, x, y:integer; indicator:boolean;);
   9  procedure LoadDrawFont(s:string);
  10  procedure DrawFontTextSpec(str:string; x, y, color:integer; spec:boolean;);
  11  procedure DrawFontText(str:string; x, y:integer);
  12 function ld_tex(name,path,folder:string):image;
  13 function readint:integer;
  14 procedure writeint(intt:integer);
  15 procedure writebool(bo:boolean);
  16 function readbool:boolean;
  17 procedure writestr(s:string);
  18 function readstr:string;
  19
  20 implementation
  21  uses canvas,imgcolor,jsr75i, vars, safeload,  items,maps, items_store;
  22
  23  //Загрузка изображения из текстурпака, ели такого нет, то происходит загрузка из архива игры
  24 function ld_tex(name,path,folder:string):image;
  25  begin
  26   if tex_pack<>'' then
  27    begin
  28     if file_exists(path+folder+name)=1 then
  29      begin
  30       ld_tex:=safely_load_image_fs(path+folder+name);
  31      end; else ld_tex:=loadimage('/'+folder+name);
  32    end;
  33   if tex_pack='' then ld_tex:=loadimage('/'+folder+name);
  34  end;
  35
  36 function readint:integer;
  37  var
  38   b:integer;
  39  begin
  40   b:=b or (read_uns_byte<<24);
  41   b:=b or (read_uns_byte<<16);
  42   b:=b or (read_uns_byte<<8);
  43   b:=b or (read_uns_byte);
  44   readint:=b;
  45  end;
  46
  47 procedure writeint(intt:integer);
  48  begin
  49   write_byte((intt>>24) and $FF);
  50   write_byte((intt>>16) and $FF);
  51   write_byte((intt>>8) and $FF);
  52   write_byte((intt) and $FF);
  53  end;
  54
  55 procedure writebool(bo:boolean);
  56  begin
  57   if bo=true then
  58    write_byte(1);
  59   else
  60    write_byte(0);
  61  end;
  62
  63 function readbool:boolean;
  64  begin
  65   readbool:=read_byte>0;
  66  end;
  67
  68 procedure writestr(s:string);
  69  var
  70   i:integer;
  71  begin
  72   for i:=0 to length(s) do
  73    write_byte(ord(getChar(s,i)));
  74  end;
  75
  76 function readstr:string;
  77  var
  78   i,b:integer;
  79   str:string;
  80  begin
  81   repeat
  82    b:=read_byte;
  83    if b=0 then break;
  84    str:=str+chr(b);
  85   until false;
  86   readstr:=str;
  87  end;
  88
  89 //Получение точки спавна
  90  function get_spawn_x:integer;
  91   begin
  92    get_spawn_x:=(255 div 2);
  93   end;
  94
  95  function get_spawn_y:integer;
  96   var
  97    iy:integer;
  98   begin
  99    for iy:=0 to 127 do
 100     if getmap(get_spawn_x,iy)<>0 then begin get_spawn_y:=(iy-2); break; end;
 101   end;
 102
 103  procedure drawSmallItem(item, x, y:integer);
 104   begin
 105    if getItemTexType(item)=0 then
 106     drawimage(tex8[getBlockTex(item)], x, y);
 107    else
 108    if getItemTexType(item)=1 then
 109     drawimage(item8[getItemTex(item)], x, y);
 110   end;
 111
 112  procedure draw_block(xx,yy:integer);
 113   begin
 114    if (getmap(xx,yy)=123) or (getmap(xx,yy)=124) then
 115     begin
 116      setclip((xx*16)-camx,(yy*16)-camy,16,16);
 117      if getmapinfo(xx,yy)<9 then drawimage(tex[142],(xx*16)-camx,(yy*16)-camy+(16-getmapinfo(xx,yy)*2)); else
 118      if getmapinfo(xx,yy)=9 then drawimage(tex[143],(xx*16)-camx,(yy*16)-camy);
 119      setclip(0,0,getwidth,getheight);
 120     end; else
 121    if (getmap(xx,yy)=92) or (getmap(xx,yy)=93) then
 122     begin
 123      if (getBlockSet(getmap(xx-1,yy))=false) and (getBlockSet(getmap(xx+1,yy))=true) then setclip((xx*16)-camx,(yy*16)-camy,10,16); else
 124      if (getBlockSet(getmap(xx+1,yy))=false) and (getBlockSet(getmap(xx-1,yy))=true) then setclip((xx*16)-camx+6,(yy*16)-camy,10,16); else
 125      if (getBlockSet(getmap(xx+1,yy))=true) and (getBlockSet(getmap(xx-1,yy))=true) then setclip((xx*16)-camx+6,(yy*16)-camy,4,16);
 126      drawimage(tex[getBlockTex(getmap(xx,yy))],(xx*16)-camx,(yy*16)-camy);
 127      setclip(0,0,getwidth,getheight);
 128     end; else
 129    if getmap(xx,yy)=27 then
 130     begin
 131      drawimage(tex[getBlockTex(getmap(xx,yy))],(xx*16)-camx,(yy*16)-camy);
 132      if getmapinfo(xx,yy)<>0 then begin if random(8)<random(6) then begin setcolor(255,255,255); fillrect((xx*16)-camx,(yy*16)-camy,16,16); end; end;
 133     end; else
 134    if getmap(xx,yy)=50 then
 135     begin
 136      drawimage(tex[getBlockTex(getmap(xx,yy))+bl_ani5],(xx*16)-camx,(yy*16)-camy);
 137     end; else
 138    if getmap(xx,yy)=51 then
 139     begin
 140      drawimage(tex[getBlockTex(getmap(xx,yy))+bl_ani5],(xx*16)-camx,(yy*16)-camy);
 141     end; else
 142    if getmap(xx,yy)=110 then
 143     begin
 144      drawimage(tex[getBlockTex(getmap(xx,yy))+bl_ani5],(xx*16)-camx,(yy*16)-camy);
 145    end; else
 146    /*if getmap(xx,yy)=106 then
 147     begin
 148      if (furnace_gg[getmapinfo(xx,yy)].f_gor<15) or (furnace_gg[getmapinfo(xx,yy)].f_got>0) then
 149       drawimage(tex[134],xx*16-camx,yy*16-camy);
 150      else
 151       drawimage(tex[get_block(0,getmap(xx,yy))],(xx*16)-camx,(yy*16)-camy);
 152     end; else*/
 153    if getmap(xx,yy)=121 then
 154     begin
 155      setclip((xx*16)-camx,(yy*16)-camy,getmapinfo(xx,yy),16);
 156      drawimage(tex[getBlockTex(getmap(xx,yy))],(xx*16)-camx,(yy*16)-camy);
 157      setclip(0,0,getWidth,getHeight);
 158     end; else
 159    if getmap(xx,yy)=122 then
 160     begin
 161      drawimage(tex[getBlockTex(getmap(xx,yy))+getmapinfo(xx,yy)],(xx*16)-camx,(yy*16)-camy);
 162     end; else
 163    if getmap(xx,yy)<>0 then
 164     drawimage(tex[getBlockTex(getmap(xx,yy))],(xx*16)-camx,(yy*16)-camy);
 165   end;
 166
 167  procedure drawItem(item, sum, x, y:integer; indicator:boolean;);
 168   var
 169    pa_xo,ugol:integer;
 170   begin
 171    if sum>0 then
 172     begin
 173      if getItemTexType(item)=0 then
 174       drawimage(tex[getBlockTex(item)], x, y);
 175       else
 176      if getItemTexType(item)=1 then
 177       drawimage(vars.item[getItemTex(item)], x, y);
 178
 179      if item=216 then
 180       begin
 181        drawimage(compas, x, y);
 182        setcolor(255,0,0);
 183        setclip(x+2, y+2, 12, 10);
 184        if pl_world=0 then
 185         drawline(get_spawn_x*16-camx, get_spawn_y*16-camy, x+8, y+7);
 186         else
 187        if pl_world=1 then
 188         drawline(random(getWidth), random(getHeight), x+8, y+7);
 189        setclip(0, 0, getWidth, getheight);
 190       end;
 191      else
 192      if item=215 then
 193       begin
 194        drawimage(clock[clock_stage], x, y);
 195       end;
 196     end;
 197
 198    if (sum>1) and indicator then
 199     begin
 200      if getItemIndLine(item) then
 201       begin
 202        pa_xo:=10000*16/getItemMax(item)*sum/10000;
 203        if pa_xo<=3 then
 204         setcolor(255,0,0);
 205        else
 206         setcolor(0,255,0);
 207        drawline(x, y+14, x+pa_xo, y+14);
 208       end;
 209
 210      if getItemIndNum(item) then
 211       drawfonttext(''+sum, x, y+8);
 212     end;
 213   end;
 214
 215
 216 //Загрузка шрифта из файла под именем s
 217 procedure LoadDrawFont(s:string);
 218  var
 219   ix:integer;
 220   im:image;
 221  begin
 222   im:=ld_tex('default_font.png', s, '');
 223   for ix:=0 to FONT_MAX_SYM do
 224    font[ix]:=rotate_image_from_image(im, ix*FONT_SYM_SIZE, 0, FONT_SYM_SIZE, FONT_SYM_SIZE, 0);
 225  end;
 226
 227 //Рисование текста графическим шрифтом
 228 procedure DrawFontTextSpec(str:string; x, y, color:integer; spec:boolean;);
 229  const
 230   FONT_UNKNOWN_SYM=$3F;
 231   FONT_SPEC_SYM=$FFA7;//UTF8
 232  var
 233   ch, i, spec_c:integer;
 234   tch:char;
 235  begin
 236   for i:=0 to length(str)-1 do
 237    begin
 238     ch:=ord(getChar(str, i));
 239
 240     if (spec) and (ch=FONT_SPEC_SYM) then
 241      begin
 242
 243       i:=i+1;
 244       if i<=length(str)-2 then
 245        begin
 246         ch:=ord(getChar(str, i+1));
 247         tch:=getChar(UpCase(str), i);
 248         if tch='0' then
 249          color:=$FF000000;
 250         else
 251         if tch='1' then
 252          color:=$FF0000AA;
 253         else
 254         if tch='2' then
 255          color:=$FF00AA00;
 256         else
 257         if tch='3' then
 258          color:=$FF00AAAA;
 259         else
 260         if tch='4' then
 261          color:=$FFAA0000;
 262         else
 263         if tch='5' then
 264          color:=$FFAA00AA;
 265         else
 266         if tch='6' then
 267          color:=$FFAA5500;
 268         else
 269         if tch='7' then
 270          color:=$FFAAAAAA;
 271         else
 272         if tch='8' then
 273          color:=$FF555555;
 274         else
 275         if tch='9' then
 276          color:=$FF5555FF;
 277         else
 278         if tch='A' then
 279          color:=$FF55FF55;
 280         else
 281         if tch='B' then
 282          color:=$FF55FFFF;
 283         else
 284         if tch='C' then
 285          color:=$FFFF5555;
 286         else
 287         if tch='D' then
 288          color:=$FFFF55FF;
 289         else
 290         if tch='E' then
 291          color:=$FFFFFF55;
 292         else
 293         if tch='F' then
 294          color:=$FFFFFFFF;
 295         else
 296          begin
 297           i:=i-2;
 298           ch:=ord(getChar(str, i));
 299           spec_c:=spec_c-2;
 300          end;
 301
 302         i:=i+1;
 303         spec_c:=spec_c+2;
 304        end;
 305      end;
 306
 307     if ch>FONT_MAX_SYM then
 308      ch:=FONT_UNKNOWN_SYM;
 309
 310     if color=FONT_STD_COLOR then
 311      DrawImage(font[ch],x+((i-spec_c)*FONT_SYM_SIZE),y);
 312     else
 313      DrawImage(ReplaceImgColor(font[ch], FONT_STD_COLOR, color), x+((i-spec_c)*FONT_SYM_SIZE), y);
 314    end;
 315  end;
 316
 317 //Рисование текста графическим шрифтом со стандартным цветом
 318 procedure DrawFontText(str:string; x, y:integer);
 319  begin
 320   DrawFontTextSpec(str, x, y, FONT_STD_COLOR, true);
 321  end;
 322
 323
 324 end.