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