请登陆或者注册新用户 用户名 密码 记住密码 注册新用户

回 帖 快速回帖 发 新 帖 刷新版面
主题:贪吃蛇

作者:forspring

专家分:0

级别:1

发表时间:2003-1-6 1:19:00    [回复] 
楼主
uses crt,dos,graph;
type
  slist=^listnode;
  listnode=record
           x,y:integer;  direction:1..4;
           shape:pointer;
           front,next:slist;
           end;
  cakere=record
         x,y:integer;
         end;

const cn=5;
var
  snake,tail:slist;
  hs,bs,ts:array[1..4]of pointer;    cs:pointer;
  size,height,width,s1,t1,s2,t2,t:integer;
  cake:array[1..cn]of cakere;
  win,stop,pause:boolean;

function initialize:boolean;
var gd,gm:integer;
begin
  gd:=detect;
  initgraph(gd,gm,'');
  if graphresult<>grok then
     initialize:=false
     else initialize:=true
end;

procedure rotate;
var i,j:integer;     p:pointer;
begin
  for i:=0 to 14 do
   for j:=0 to 14 do
     putpixel(100+j,114-i,getpixel(i,j));
  getmem(p,size);  getimage(100,100,114,114,p^);
  putimage(0,0,p^,normalput);
end;

procedure drawheadshape;
var i:byte;
begin
  setactivepage(1);
  getmem(hs[1],size);
  line(7,0,0,9);  line(7,0,14,9); line(0,9,0,14); line(14,9,14,14);  line(0,14,14,14);
  setcolor(red);  circle(4,9,1);  circle(10,9,1);
  getimage(0,0,14,14,hs[1]^);
  for i:=2 to 4 do  begin
  getmem(hs[i],size);  rotate;   getimage(0,0,14,14,hs[i]^);     end;
  setactivepage(0);
end;

procedure drawbodyshape;
var i:byte;
begin
  setactivepage(1);
  getmem(bs[1],size);  cleardevice;  setcolor(white);
  line(7,0,0,9); line(7,0,14,9);  line(7,6,0,14);  line(7,6,14,14);
  getimage(0,0,14,14,bs[1]^);
  for i:=2 to 4 do  begin
  getmem(bs[i],size);  rotate;    getimage(0,0,14,14,bs[i]^);     end;
  setactivepage(0);
end;

procedure drawtailshape;
var i:byte;
begin
  setactivepage(1);
  getmem(ts[1],size); cleardevice;     setcolor(white);
  line(0,0,14,0);   line(0,0,7,14);  line(14,0,7,14);
  getimage(0,0,14,14,ts[1]^);
  for i:=2 to 4 do begin
  getmem(ts[i],size); rotate;     getimage(0,0,14,14,ts[i]^);  end;
  setactivepage(0);
end;

procedure drawcakeshape;
begin
  setactivepage(1);   cleardevice;
  getmem(cs,size);   setcolor(yellow);
  circle(7,7,6);     setfillstyle(2,yellow);
  floodfill(7,7,yellow);
  getimage(0,0,14,14,cs^);
  setactivepage(0);
end;

procedure drawbasicarea;
begin
  s1:=(640-width*15) div 2;        t1:=(480-height*15) div 2;
  s2:=s1+width*15-1;               t2:=t1+height*15-1;
  setlinestyle(0,0,thickwidth);     setcolor(green);
  line(s1-5,t1-5,s2+5,t1-5);       line(s2+5,t1-5,s2+5,t2+5);
  line(s2+5,t2+5,s1-5,t2+5);       line(s1-5,t2+5,s1-5,t1-5);
  moveto(s1-5,t2+10);
  setcolor(white);   outtext('Enter');  setcolor(darkgray);  outtext(' -start   ');
  setcolor(white);   outtext('Q');      setcolor(darkgray);  outtext(' -quit   ');
  setcolor(white);   outtext('P');      setcolor(darkgray);  outtext(' -pause   ');
end;

procedure getready;
begin
  size:=imagesize(0,0,14,14);
  drawheadshape;
  drawbodyshape;
  drawtailshape;
  drawcakeshape;
  height:=20;  width:=30;
  drawbasicarea;
end;

procedure initsnake;
var temp:slist;
begin
  new(temp);
  with temp^  do begin shape:=hs[4];   x:=2;   y:=1;    direction:=4    end;
  snake:=temp;
  new(temp);
  with temp^  do begin shape:=ts[4];   x:=1;   y:=1;
                       next:=nil;      front:=snake;
                       direction:=4    end;
  tail:=temp;   snake^.next:=tail;         snake^.front:=nil
end;

procedure listappend;
var temp:slist;
begin
  new(temp);
  with temp^ do  begin
     direction:=tail^.direction;     shape:=bs[direction];
     front:=tail^.front;             tail^.front^.next:=temp;
     next:=tail;
     x:=tail^.x;                     y:=tail^.y;
     end;
  case tail^.direction of
       1: tail^.y:=tail^.y+1 ;
       2: tail^.x:=tail^.x+1 ;
       3: tail^.y:=tail^.y-1 ;
       4: tail^.x:=tail^.x-1 ;
     end;
  tail^.front:=temp;
end;

procedure createcake(i:integer);
var k:integer;   n:integer;    b:boolean;    temp:slist;
begin
  repeat
   b:=true;
   n:=random(height*width)+1;
   for k:=1 to cn do
    if ((cake[k].y-1)*width+cake[k].x)=n then b:=false;
   temp:=snake;
   while temp<>nil do
   begin   if ((temp^.y-1)*width+temp^.x)=n then b:=false;
          temp:=temp^.next;end;
  until b;
  if n mod width=0 then cake[i].x:=width
                 else cake[i].x:=n mod width;
  cake[i].y:=n div width+1;
  putimage((cake[i].x-1)*15+s1,(cake[i].y-1)*15+t1,cs^,normalput);
end;

procedure timer(flags,cs,ip,ax,bx,cx,dx,si,di,ds,es,bp:word);interrupt;
var s:string;    key:char;            tt1,tt2:integer;
begin
  if keypressed then  begin
      key:=readkey;
      case key of
       #75    :if snake^.direction<>4 then begin snake^.direction:=2; snake^.shape:=hs[snake^.direction] end;
       #77    :if snake^.direction<>2 then begin snake^.direction:=4; snake^.shape:=hs[snake^.direction] end;
       #80    :if snake^.direction<>1 then begin snake^.direction:=3; snake^.shape:=hs[snake^.direction] end;
       #72    :if snake^.direction<>3 then begin snake^.direction:=1; snake^.shape:=hs[snake^.direction] end;
       'p','P':pause:=true;
       'q','Q':stop:=true;
      end   end;
  t:=t+1;
  setviewport(s2-50,t1-20,s2-10,t1-10,clipon);  clearviewport;
  setviewport(0,0,639,479,clipon);      moveto(s2-50,t1-20);
  str(t div 1080,s);
  if (t div 1080<10) then outtext('0');
  outtext(s);        outtext(':');
  str((t mod 1080)div 18,s);
  if ((t mod 1080)div 18<10) then outtext('0');
  outtext(s);
end;

procedure play;
var key:char;     i,j:integer;   temp:slist;
    cx,cy,dd:integer;     oldvec,newvec:pointer;
begin
  initsnake;     randomize;       win:=true;     stop:=false;  pause:=false;
  for i:=1 to cn do   createcake(i);
  cx:=1;  cy:=1;  dd:=4;  t:=0;
  getintvec($1c,oldvec);
  newvec:=@timer;
  setintvec($1c,newvec);
  repeat
    if pause then begin setintvec($1c,oldvec);  readln;
                        setintvec($1c,newvec);  pause:=false;
                  end;
    putimage((snake^.x-1)*15+s1,(snake^.y-1)*15+t1,snake^.shape^,normalput);
    if (cx>=1)and(cx<=width)and(cy>=1)and(cy<=height) then
    putimage((cx-1)*15+s1,(cy-1)*15+t1,ts[dd]^,xorput);
    cx:=tail^.x;    cy:=tail^.y;        dd:=tail^.direction;
    temp:=tail;
    while temp^.front<>nil do
      begin   with temp^ do begin
              if (x>=1)and(x<=width)and(y>=1)and(y<=height)
                then putimage((x-1)*15+s1,(y-1)*15+t1,shape^,normalput);
              x:=front^.x;   y:=front^.y;
              direction:=front^.direction;
              shape:=bs[direction];  end;
              temp:=temp^.front     end;
    tail^.shape:=ts[tail^.direction];
    case snake^.direction of
      1:snake^.y:=snake^.y-1;
      2:snake^.x:=snake^.x-1;
      3:snake^.y:=snake^.y+1;
      4:snake^.x:=snake^.x+1;
      end;
    for i:=1 to cn do
      if (snake^.x=cake[i].x)and(snake^.y=cake[i].y)
      then  begin listappend;   createcake(i)  end;
    temp:=snake^.next;
    while temp<>nil do
      begin if (temp^.x=snake^.x)and(temp^.y=snake^.y) then
          begin stop:=true;  win:=false; exit end; temp:=temp^.next;  end;
    if (snake^.x<1)or(snake^.x>width)or(snake^.y<1)or(snake^.y>height)
     then begin  win:=false;  exit;  end;
  delay(300);
  until stop=true;
  setintvec($1c,oldvec);
end;

begin
  if not initialize then exit;
  getready;
  play;
  closegraph
end.

 

作者:Joshua

专家分:20

级别:1

发表时间:2003-1-30 19:56:00    [回复]  [引用]
1楼
不知道为什么运行不起来。

 

作者:soarcncn

专家分:0

级别:1

发表时间:2003-2-5 9:26:00    [回复]  [引用]
2楼
怎么运行啊?

 

作者:HRG

专家分:1030

级别:6

发表时间:2003-2-11 14:38:00    [回复]  [引用]
3楼
呸,看了半天,在后面加一句“不知道怎么运行不起来”,让人失望。

 

作者:mx

专家分:0

级别:1

发表时间:2003-3-1 20:33:00    [回复]  [引用]
4楼
太长了

 

作者:mx

专家分:0

级别:1

发表时间:2003-3-1 20:34:00    [回复]  [引用]
5楼
太长了

 

作者:mx

专家分:0

级别:1

发表时间:2003-3-1 20:41:00    [回复]  [引用]
6楼
编译不通过

 

作者:mx

专家分:0

级别:1

发表时间:2003-3-1 20:44:00    [回复]  [引用]
7楼
shape:pointer;不对 6行
           

 

作者:LittleMud

专家分:440

级别:3级别:3

发表时间:2003-3-7 19:39:00    [回复]  [引用]
8楼
关键是理解其思想
而不是保存其代码

 

作者:vrace

专家分:3590

级别:18级别:18级别:18级别:18级别:18

发表时间:2003-3-7 22:51:00    [回复]  [引用]
9楼
我有 DirectX 版的贪吃蛇!谁要?
我的东东需要 Visual C++ 6.0 + DirectX 8.1 SDK 才能编译!
要的话请说一声!
Contact vrace_studios@hotmail.com for more.

 

作者:jiss123

专家分:0

级别:1

发表时间:2003-3-19 0:31:00    [回复]  [引用]
10楼
什么东西

 

作者:编程柠檬

专家分:0

级别:1

发表时间:2003-4-22 22:17:00    [回复]  [引用]
11楼
运行不起有可能是缺少crt,dos,graph程序包,属于不完整的Pascal,要到网上下载。

 

作者:cookbjy

专家分:0

级别:1

发表时间:2003-6-30 10:12:00    [回复]  [引用]
12楼
能不能讲一讲它的原理?

 

作者:刀锋战士

专家分:0

级别:1

发表时间:2003-7-1 14:03:00    [回复]  [引用]
13楼
能不能贴个有用的啊 急用啊!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

 

作者:ronaldinho19

专家分:0

级别:1

发表时间:2003-10-8 19:22:00    [回复]  [引用]
14楼
呵呵,如果考试有这道题目的话………………没想法了~~~

 

作者:clock2008

专家分:0

级别:1

发表时间:2003-10-11 10:02:00    [回复]  [引用]
15楼
用什么软件可以直接把他导入pacal里啊

 

作者:奥特曼

专家分:360

级别:2

发表时间:2003-10-12 11:24:00    [回复]  [引用]
16楼
把它复制下来粘贴到记事本,然后改变扩展名为*.PAS

 

作者:good-boy

专家分:20

级别:1

发表时间:2003-10-16 18:13:00    [回复]  [引用]
17楼
你这个人真是的,复制都要长时间!!!

 

作者:野蛮人

专家分:0

级别:1

发表时间:2003-11-23 14:35:00    [回复]  [引用]
18楼
看不懂

 

作者:twilight

专家分:50

级别:1

发表时间:2003-11-23 16:46:00    [回复]  [引用]
19楼
我打过补丁了,还是运行不了,一闪而过

 

作者:张欣

专家分:30

级别:1

发表时间:2004-8-15 15:52:00    [回复]  [引用]
20楼
file not found (GRAPH.TPU)

 

[首页] [上页] [下页] [尾页]     共有 48 回帖 当前第 1 页(共3页 20帖/页)     跳转至第
回 帖 快速回帖 发 新 帖 刷新版面

版主管理:  删除此帖   转贴   置顶   取消精华   强制结帖   >>>进入管理页面