src/func.mpsrc

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