home *** CD-ROM | disk | FTP | other *** search
/ The Unsorted BBS Collection / thegreatunsorted.tar / thegreatunsorted / hacking / phreak_utils_pc / bbp_tool.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1995-04-01  |  12.7 KB  |  418 lines
  1. unit bbp_tool;
  2.  
  3. interface
  4.  
  5. procedure tools;
  6.  
  7. implementation
  8.  
  9. uses bbp_vars, grwins, crt, extras, editrout, optimer, vgagraph,
  10.      video, {vfont8x8,} types, grmenus, sos;
  11.  
  12. procedure tools;
  13. var choice:byte;
  14. procedure exportbook(fn:string);
  15. var x,y,z :word;
  16.     c     :numberrec;
  17.     t     :text;
  18. begin
  19.   openbox(10,28,7,51,11,true,true,false);
  20.   textattr:=colors.win_title;
  21.   center(7,' Export Phone Book ');
  22.   vmemwrite(31,9,'To:',colors.win_text);
  23.   gotoxy(35,9);
  24.   setcursorsize($6,$7); edituc(fn,12); setcursorsize($32,$32);
  25.   center(11,' Working ');
  26.   sosopen;
  27.   sosfopen(phonebookname);
  28.   assign(t,fn);
  29.   {$I-}
  30.   rewrite(t);
  31.   {$I+}
  32.   if ioresult<>0 then begin
  33.     center(9,'** I/O ERROR !! **');
  34.     delayms(2000);
  35.     closebox(10);
  36.     exit;
  37.   end;
  38.   writeln(t,'<<< This Phone Book exported using BlueBEEP! v',version);
  39.   writeln(t,'<<< Copyright (C) 1993-1995 by Onkel Dittmeyer');
  40.   writeln(t);
  41.   writeln(t,' #    Name                                  Number');
  42.   writeln(t,'------------------------------------------------------------------------------');
  43.   for x:=1 to maxnums do begin
  44.     sosread(@c,sizeof(c));
  45.     c.name:=scrambled(c.name);
  46.     c.number:=scrambled(c.number);
  47.     if c.name<>blankpbentry then begin
  48.       write(t,x:3,'   ',c.name);
  49.       for y:=1 to 38-length(c.name) do write(t,' ');
  50.       writeln(t,c.number);
  51.     end;
  52.   end;
  53.   sosclose;
  54.   writeln(t,'---EOF------------------------------------------------------------------------');
  55.   close(t);
  56.   closebox(10);
  57. end;
  58.  
  59. procedure importoldtlo;
  60. var s:string;
  61.     temprec:oldtlonumrec;
  62.     x:word;
  63. begin
  64.   openbox(1,10,10,70,16,true,true,false);
  65.   textattr:=colors.win_title;
  66.   center(10,'Import TLO 0.1ß-0.9ß Phone Book');
  67.   textattr:=colors.win_text;
  68.   gotoxy(13,12); write('Path to TLO files: ');
  69.   s:='C:\TLO';
  70.   setcursorsize($6,$7);
  71.   edituc(s,36);
  72.   setcursorsize($32,$32);
  73.   center(14,'** Importing **');
  74.   if not exist(s+'\TARGETS.TLO') then begin
  75.     center(14,'** FILES NOT FOUND! **');
  76.     delayms(2000);
  77.     closebox(1);
  78.     exit;
  79.   end;
  80.   assign(oldtlobook,s+'\TARGETS.TLO');
  81.   reset(oldtlobook);
  82.   sosopen;
  83.   sosfopen(phonebookname);
  84.   for x:=0 to filesize(oldtlobook)-1 do begin
  85.     read(oldtlobook,temprec);
  86.     numbers[x+1]^.name:=temprec.descrip;
  87.     numbers[x+1]^.number:=temprec.number;
  88.     if numbers[x+1]^.name='NONE' then numbers[x+1]^.name:=blankpbentry;
  89.     if numbers[x+1]^.number='NONE' then numbers[x+1]^.number:='';
  90.     sosseek(sizeof(numberrec)*x);
  91.     numbers[x+1]^.name:=scrambled(numbers[x+1]^.name);
  92.     numbers[x+1]^.number:=scrambled(numbers[x+1]^.number);
  93.     soswrite(numbers[x+1],sizeof(numberrec));
  94.     numbers[x+1]^.name:=scrambled(numbers[x+1]^.name);
  95.     numbers[x+1]^.number:=scrambled(numbers[x+1]^.number);
  96.   end;
  97.   close(oldtlobook);
  98.   sosclose;
  99.   center(14,'Successfully imported !');
  100.   victorioustune;
  101.   tapenter(16);
  102.   closebox(1);
  103. end;
  104.  
  105. procedure importnewtlo;
  106. var s       :string;
  107.     temprec :newtlonumrec;
  108.     x, cnt  :word;
  109. begin
  110.   openbox(23,07,10,73,19,true,true,false);
  111.   textattr:=colors.win_title;
  112.   center(10,'Import TLO 1.0 or later Phone Book');
  113.   textattr:=colors.win_text;
  114.   center(12,'NOTE: If using more than one phone book in TLO 3.0 or later,');
  115.   center(13,'      only the first five phonebooks will be imported.      ');
  116.   gotoxy(13,15); write('Path to TLO files: ');
  117.   s:='C:\TLO';
  118.   setcursorsize($6,$7);
  119.   edituc(s,36);
  120.   setcursorsize($32,$32);
  121.   center(17,'** Importing **');
  122.   if not exist(s+'\NUMBERS.TLO') then begin
  123.     center(17,'** FILES NOT FOUND! **');
  124.     delayms(2000);
  125.     closebox(23);
  126.     exit;
  127.   end;
  128.   assign(newtlobook,s+'\NUMBERS.TLO');
  129.   reset(newtlobook);
  130.   sosopen;
  131.   sosfopen(phonebookname);
  132.   cnt:=filesize(newtlobook)-1;
  133.   if cnt>maxnums then cnt:=maxnums;
  134.   for x:=0 to cnt do begin
  135.     read(newtlobook,temprec);
  136.     numbers[x+1]^.name:=temprec.descrip;
  137.     numbers[x+1]^.number:=temprec.number;
  138.     if numbers[x+1]^.name='NONE' then numbers[x+1]^.name:=blankpbentry;
  139.     if numbers[x+1]^.number='NONE' then numbers[x+1]^.number:='';
  140.     if numbers[x+1]^.name='' then numbers[x+1]^.name:=blankpbentry;
  141.     if numbers[x+1]^.number='-UNUSED-' then numbers[x+1]^.number:='';
  142.     sosseek(sizeof(numberrec)*x);
  143.     numbers[x+1]^.name:=scrambled(numbers[x+1]^.name);
  144.     numbers[x+1]^.number:=scrambled(numbers[x+1]^.number);
  145.     soswrite(numbers[x+1],sizeof(numberrec));
  146.     numbers[x+1]^.name:=scrambled(numbers[x+1]^.name);
  147.     numbers[x+1]^.number:=scrambled(numbers[x+1]^.number);
  148.   end;
  149.   close(newtlobook);
  150.   sosclose;
  151.   center(17,'Successfully imported !');
  152.   victorioustune;
  153.   tapenter(19);
  154.   closebox(23);
  155. end;
  156.  
  157. procedure importcardlist;
  158. var s:string;
  159.     tempstring:string;
  160.     temprec:numberrec;
  161.     x:word;
  162.     t:text;
  163. begin
  164.   openbox(1,10,10,70,16,true,true,false);
  165.   textattr:=colors.win_title;
  166.   center(10,'Import Calling Card List');
  167.   textattr:=colors.win_text;
  168.   gotoxy(13,12); write('File to import: ');
  169.   s:='CARDLIST.TXT';
  170.   setcursorsize($6,$7);
  171.   edit(s,36);
  172.   setcursorsize($32,$32);
  173.   center(14,'** Importing **');
  174.   if not exist(s) then begin
  175.     center(14,'** FILE NOT FOUND! **');
  176.     delayms(2000);
  177.     closebox(1);
  178.     exit;
  179.   end;
  180.   assign(t,s);
  181.   reset(t);
  182.   sosopen;
  183.   sosfopen(phonebookname);
  184.   x:=0;
  185.   repeat
  186.     sosread(@temprec,sizeof(temprec));
  187.   until scrambled(temprec.name)=blankpbentry;
  188.   x:=sos_filepos-1;
  189.   while not eof(t) do begin
  190.     readln(t,tempstring);
  191.     numbers[x+1]^.name:='Calling Card';
  192.     numbers[x+1]^.number:=tempstring;
  193.     numbers[x+1]^.name:=scrambled(numbers[x+1]^.name);
  194.     numbers[x+1]^.number:=scrambled(numbers[x+1]^.number);
  195.     sosseek(x*sizeof(numberrec));
  196.     soswrite(numbers[x+1],sizeof(numberrec));
  197.     numbers[x+1]^.name:=scrambled(numbers[x+1]^.name);
  198.     numbers[x+1]^.number:=scrambled(numbers[x+1]^.number);
  199.     inc(x);
  200.   end;
  201.   close(t);
  202.   sosclose;
  203.   center(14,'Successfully imported !');
  204.   victorioustune;
  205.   tapenter(16);
  206.   closebox(1);
  207. end;
  208.  
  209. procedure importphonebook;
  210. var s, tempstring     :string;
  211.     temprec           :numberrec;
  212.     numcol,namecol    :byte;
  213.     x                 :word;
  214.     t                 :text;
  215. begin
  216.   openbox(1,07,10,73,18,true,true,false);
  217.   textattr:=colors.win_title;
  218.   center(10,'Import Phone Book');
  219.   textattr:=colors.win_text;
  220.   setcursorsize($6,$7);
  221.   s:='PHONEBK.LST';
  222.   namecol:=7;
  223.   numcol:=45;
  224.   gotoxy(13,12); write('Import from ASCII file: ');    edit(s,36);
  225.   gotoxy(12,13); write('Entry name start column: ');   editbyte(namecol);
  226.   gotoxy(10,14); write('Entry number start column: '); editbyte(numcol);
  227.   setcursorsize($32,$32);
  228.   center(16,'** Importing **');
  229.   if not exist(s) then begin
  230.     center(16,'** FILE NOT FOUND! **');
  231.     delayms(2000);
  232.     closebox(1);
  233.     exit;
  234.   end;
  235.   assign(t,s);
  236.   reset(t);
  237.   sosopen;
  238.   sosfopen(phonebookname);
  239.   x:=0;
  240.   repeat
  241.     sosread(@temprec,sizeof(temprec));
  242.   until scrambled(temprec.name)=blankpbentry;
  243.   x:=(sos_filepos div sizeof(numberrec))-1;
  244.   sosseek(x*sizeof(numberrec));
  245.   while not eof(t) do begin
  246.     readln(t,tempstring);
  247.     if tempstring<>'' then if tempstring[1]<>';' then begin
  248.       numbers[x+1]^.name:=striptrail(copy(tempstring,namecol,pbentrynamelen));
  249.       numbers[x+1]^.number:=striptrail(copy(tempstring,numcol,pbentrynumlen));
  250.       numbers[x+1]^.name:=scrambled(numbers[x+1]^.name);
  251.       numbers[x+1]^.number:=scrambled(numbers[x+1]^.number);
  252.       soswrite(numbers[x+1],sizeof(numberrec));
  253.       numbers[x+1]^.name:=scrambled(numbers[x+1]^.name);
  254.       numbers[x+1]^.number:=scrambled(numbers[x+1]^.number);
  255.       inc(x);
  256.     end;
  257.   end;
  258.   close(t);
  259.   sosclose;
  260.   center(16,'Successfully imported !');
  261.   victorioustune;
  262.   tapenter(18);
  263.   closebox(1);
  264. end;
  265.  
  266. procedure flythroughspace;
  267. const numstars=280;                          { number of stars on screen     }
  268.       zmin=1;                                { closest star                  }
  269.       zmax=200;                              { farest star                   }
  270.       xymax=23100;                           { MAXINT / SQRT(2) due turning  }
  271.       sfarbe=31;                             { star base color               }
  272. var   stars      :array[0..numstars] of record x,y,z:integer; end;
  273.       starsbuf   :array[0..numstars] of record ox,oy,oc:integer; end;
  274.       drawed     :boolean;                   { screen empty --> zeroed       }
  275.       xmove,ymove:integer;
  276.       xm,ym,dz :integer;
  277.       cs,sn    :longint;                     { cosinus/sinus pre-calculation }
  278.       w        :real;
  279.       xmp,ymp:integer;
  280.       ch     :char;
  281.       speed  :integer;
  282.       turn   :real;
  283.       x      :longint;
  284.       vsave  :^vgascreen;
  285.       tmp    :word;
  286. procedure initstars;
  287. var i:integer;
  288. begin
  289.   xm:=160;
  290.   ym:=100;
  291.   randomize;
  292.   for i:=0 to numstars do with stars[i] do begin
  293.     x:=integer(random(xymax*2))-xymax;
  294.     y:=integer(random(xymax*2))-xymax;
  295.     z:=random(zmax-zmin)+zmin;
  296.   end;
  297. end;
  298. procedure parastars(p1:integer;p2:real;xmv,ymv:integer);
  299. var i:word;
  300. begin
  301.   xmove:=xmv;
  302.   ymove:=ymv;
  303.   dz:=p1; w:=p2;
  304.   xm:=160;
  305.   ym:=100;
  306.   cs:=round(cos(w)*2048);
  307.   sn:=round(sin(w)*2048);
  308. end;
  309. procedure clearstars;
  310. var i:integer;
  311. begin
  312.   for i:=0 to numstars do with starsbuf[i] do putpixel(ox,oy,oc);
  313. end;
  314. procedure drawstars;
  315. var i:word;
  316.     xx,yy:longint;
  317. begin
  318.   for i:=0 to numstars do begin
  319.     with stars[i] do begin
  320.       z:=z+dz;
  321.       x:=(x*cs) div 2048+(y*sn) div 2048; {in 68000 assembler wird aus div 2048 = asr (),11 !}
  322.       y:=(y*cs) div 2048-(x*sn) div 2048;
  323.       x:=x+xmove;
  324.       y:=y+ymove;
  325.       if (z<zmin) or (z>zmax) then begin
  326.         x:=random(xymax*2)-xymax;
  327.         y:=random(xymax*2)-xymax;
  328.         if z>zmax then z:=zmin else z:=zmax;
  329.       end;
  330.       xx:=xm+x div z;
  331.       yy:=ym-y div z;
  332.     end;
  333.     with starsbuf[i] do begin
  334.       if drawed then putpixel(ox,oy,vsave^[oy*320+ox]);
  335.       ox:=xx;oy:=yy;
  336.       if mem[$a000:yy*320+xx]=0 then putpixel(xx,yy,sfarbe-(stars[i].z div 17));
  337.     end;
  338.   end;
  339.   drawed:=true;
  340. end;
  341. begin
  342.   move(mem[vadr:0],save,4000);
  343.   ch:='S';
  344.   speed:=-1;
  345.   turn:=0.00;
  346.   xmp:=0;
  347.   ymp:=0;
  348.   enter256colormode;
  349.   {text8x8(75,96,'BLUEBEEP IS SLEEPING...',gray,1);}
  350.   new(vsave);
  351.   move(mem[$a000:0],vsave^,64000);
  352.   parastars(speed,turn,xmp,ymp);
  353.   initstars;
  354.   repeat
  355.     drawstars;
  356.     if keypressed then begin
  357.       ch:=readkey;
  358.       if ch=#0 then ch:=readkey;
  359.       case ch of
  360.         CurUp:inc(speed);                  { speed increase                  }
  361.         CurDn:dec(speed);                  { speed decrease                  }
  362.         CurLf:turn:=turn+0.005;            { turn left                       }
  363.         CurRt:turn:=turn-0.005;            { turn right                      }
  364.           '4':dec(xmp,5);                  { moves left                      }
  365.           '6':inc(xmp,5);                  { moves right                     }
  366.           '8':dec(ymp,5);                  { moves up                        }
  367.           '2':inc(ymp,5);                  { moves down                      }
  368.           '0':begin                        { screenclear                     }
  369.                 cleardevice;
  370.                 for tmp:=0 to 63999 do vsave^[tmp]:=0;
  371.               end;
  372.       end;
  373.       parastars(speed,turn,xmp,ymp);
  374.     end;
  375.   until ch=Esc;
  376.   dispose(vsave);
  377.   for x:=1 to 200 do begin { "Black Hole" Effect }
  378.     turn:=turn+0.005;
  379.     parastars(speed,turn,xmp,ymp);
  380.     drawstars;
  381.   end;
  382.   closegraph;
  383.   setcursorsize($32,$32);
  384.   move(save,mem[vadr:0],4000);
  385. end;
  386.  
  387. begin
  388.   choice:=1;
  389.   repeat
  390.     menuitem[1]:='Export Phone Book';
  391.     menuitem[2]:='Print Phone Book';
  392.     menuitem[3]:='Import phone book from ASCII';
  393.     menuitem[4]:='Import TLO V0.1-V0.9 phone book';
  394.     menuitem[5]:='Import TLO V1.0-V3.3 phone book';
  395.     menuitem[6]:='Import Card List';
  396.     menuitem[7]:='Flight Through Space';
  397.     menuinfo[1]:='Export your phone book to an ASCII file on disk';
  398.     menuinfo[2]:='Export your phone book to a list on the printer';
  399.     menuinfo[3]:='Import phone book from ASCII text file';
  400.     menuinfo[4]:='Import your TLO (The Little Operator) version 0.1ß to 0.9ß to BlueBEEP!';
  401.     menuinfo[5]:='Import your TLO (The Little Operator) version 1.0 or later to BlueBEEP!';
  402.     menuinfo[6]:='Import Calling Card List from a text file';
  403.     menuinfo[7]:='Relax, lean back, and enjoy a flight through space';
  404.     menucount:=7;
  405.     choice:=menu(19,4,choice,true,true,true,true,true);
  406.     case choice of
  407.       1: exportbook('PHONEBK.LST');
  408.       2: exportbook('LPT1');
  409.       3: importphonebook;
  410.       4: importoldtlo;
  411.       5: importnewtlo;
  412.       6: importcardlist;
  413.       7: flythroughspace;
  414.     end;
  415.   until choice=0;
  416. end;
  417. end.
  418.