GIKO.LIB 使えるソースコード置場

自作か　２CHで見かけたソースを集積しましょう
　言語不問　ただし

１）ほぼ正しく動くコードである事
２）でもあんまり長いのはツマラナイ
３）転載は転載元を明記する事

※このスレのコード批判は各言語スレに転載して行う事

関連：
【圧縮したコードは】　七行プログラミング
http://piza2.2ch.net/test/read.cgi/tech/984182993/

【ネタコードは】　みんなでCのコードを1行ずつ書いていくスレ
http://piza2.2ch.net/test/read.cgi/tech/1000040562/

【技巧派は】トリッキーなコード
http://piza2.2ch.net/test/read.cgi/tech/983191866/

２だ。

出現場所　 http://piza2.2ch.net/test/read.cgi/tech/990219336/825
double　distance(double　x0,double y0,double x1,double y1,double px,double py)
{
　double　xc=px-x1;　//点を平行移動
　double　yc=py-y1;
　double　x2=x0-x1;　//線分のもう一方の端を平行移動
　double　y2=y0-y1;
　if　(　x2*xc+y2*yc　<0　)　{
　　return　hypot(x　c,yc　);
　};
　　xc=px-x0;
　　yc=py-y0;
　　x2=x1-x0;
　　y2=y1-y0;
　if　(　x2*xc+y2*yc　<0　)　{
　　return　hypot(　xc,yc　) ;
　};
　return　fabs(　y2*xc-x2*yc　)　/　hypot(　x2,y2　)　;
}

function FourNum(s:string):double ; //出現場所　http://piza2.2ch.net/test/read.cgi/tech/995950803/11
var num:double;
var sym:char;
　procedure addsub;forward;
　procedure next;
　var i,j:integer;
　const sep='^+-/*()<>';
　begin
　 if s='' then begin sym:=#0;exit;end;
　 for j:=1 to length(sep) do
　　if s[1]=sep[j] then begin sym:=s[1]; delete(s,1,1);s:=trim(s); exit;end ;
　　sym:=#1;
　 for i:=2 to length(s) do
　 for j:=1 to length(sep) do
　　if s[i]=sep[j] then begin
　　　　num:=StrToFloat(copy(s,1,i-1)); delete(s,1,i-1); exit;end;
　　num:=StrToFloat(s);s:='';
　end;
　 procedure factor;
　 begin
　　if(sym = #1) then　next
　　else　if(sym = '(') then
　　　begin next; addsub;
　　　　 if(sym <> ')') then raise Exception.Create(' )がない');
　　　　 next;
　　　end
　　　else raise Exception.Create('数があるべき');
　 end;
　 procedure muldiv;
　 var savenum:double;　 var oldsym:char;
　 begin
　　factor;
　　while (sym in ['*','/','^'] ) do begin
　　　savenum:=num;oldsym:=sym;　next;
　　factor;
　　　case oldsym of
　　　　　　'*': num:=savenum*num;
　　　　　　'/': num:=savenum/num;
　　　　　　'^': num:=power(savenum,num);
　　　end;
　　end;
　 end;
　procedure addsub;
　var savenum:double;　var oldsym:char;
　begin
　　　case sym of
　　　　'+': begin next;　muldiv;　 end;
　　　　'-': begin next;　muldiv; num:=-num; end;
　　　　　else　　　 muldiv;
　　　end;
　　while (sym in [ '+','-'] ) do
　　 begin　savenum:=num;oldsym:=sym;　next; muldiv;
　　　　case oldsym of
　　　　'+': num:=savenum+num;
　　　　'-': num:=savenum-num;
　　　　end;
　　 end;
　end;
begin 　next;　 addsub;　 Result:=num;
end;

/*
　荒い √(x*x+y*y) の計算
　　最も精度が悪い場所で1% 程度の誤差
　>>3 のような場所で荒い判定に使う

*/
double roughHypot1(double x, double y)
{
x=fabs(x);
y=fabs(y);
if (x<y){ double w=x;x=y;y=w;};
return x+ (y*y/x)* 0.429;
}

出所：最速の素数判定アルゴリズム　
http://piza2.2ch.net/test/read.cgi/tech/993457354/207

効能：
　0〜 ((2^n) -1) のビット反転テーブルをtblに作成する
ここで言うビット反転とは
000 -> 000
001 -> 100
010 -> 010
011 -> 110　と MSB と LSB を入れ替える事

procedure MkBitRevTbl(n:integer;var tbl:array of integer);
var i,j,k,mh,m:integer;
begin
　m :=1 shl n;
　mh:=m div 2; //mh=msbのみ1のデータ
　i:=0; // 1単位に増えるアドレス
　j:=0; // ビット反転アドレス
　while true do
　begin
　 tbl[i]:=j;
　　inc(i);if i>=m then break;
　　k:=mh;　　　　　　　 //mh=msbのみ1のデータ
　　while k<=j do begin　//上のビットが立っていたら
　　 j:= j and　(not k); //それを落としてゆく i-kでも良い筈
　　　k:=k div 2;
　　end;
　　j:= j or k;
　end;
end;

出所：最速の素数判定アルゴリズム
http://piza2.2ch.net/test/read.cgi/tech/993457354/214

FFTをする為に2のベキで収まる数を求める関数
function iGTexp2(k:integer):integer; //k < 2^n となる 2^n
begin
　k:=k or (k shr 16);　//ビットシフトしながらORすると
　k:=k or (k shr 8);　//下位ビットが全部1になる
　k:=k or (k shr 4);
　k:=k or (k shr 2);
　k:=k or (k shr 1);
　Result:=k+1;　　　　//１を足せば 2^nになる
end;

function iLog2(m:integer):integer; //m=2^n を与えて nを返す
begin
　　　if m>=$10000 then Result:=iLog2(m shr 16)+16
else if m>=$100 then Result:=iLog2(m shr 8)+8
else if m>=$10 then Result:=iLog2(m shr 4)+4
else if m>=4 then Result:=iLog2(m shr 2)+2
else if m>=2 then Result:=iLog2(m shr 1)+1
else Result:=0; //1か0 0ならエラーだけど知らない
end;

>>3 の整数化処理

{S〜E　の線分と点Pとの距離　}
function　iSegmentDistance(const　S,E,P:TPoint):integer;
var　pxm,pym,x0m,y0m:integer;
begin
　pxm:=P.x-E.x;　pym:=P.y-E.y;
　x0m:=S.x-E.x;　y0m:=S.y-E.y;
　if　MulSubSGN(-x0m,pxm,y0m,pym)<=0　　then　begin　　{-a*b　+　c*d}
　　　　Result:=iHypot(pxm,pym);
　　end　else　begin
　　　pxm:=P.x-S.x;　pym:=P.y-S.y;
　　　x0m:=E.x-S.x;　y0m:=E.y-S.y;
　if　MulSubSGN(-x0m,pxm,y0m,pym)<=0　　then　begin
　　　Result:=iHypot(pxm,pym);
　　end　else　begin
　　　Result:=ihypot(x0m,y0m);
　　　if　Result<=0　then　Result:=　iHypot(pxm,pym)
　　　else　　　Result:=　　abs(MulSubDiv(x0m,pym,y0m,pxm,result))　;
　　end;
　end;
end;

{iHypot は http://www.infoeddy.ne.jp/~tensyo/prog/linealgo.htm からの拝借物
>>5 を整数で計算するもので リンク先では iHypot2 となっている

nが2のべき乗か判定する。
(たしかトリッキースレ)
long powerof2(long n) {
return (n > 0) && ((n & (n - 1)) == 0);
}

DBG_FLGが立っているときだけprintfしてくれるマクロ

#ifdef DBG_FLG
#define dprintf printf
#else
#define dprintf 1?(void)0:printf
#endif

プロパティエディタに表示される 列挙型の名前一覧を貰う

procedure GetEnumNameList(TypeInfo: PTypeInfo;str:TStrings);
var i:integer;
var T: PTypeData;
var s:string;
begin
　T := GetTypeData(GetTypeData(TypeInfo)^.BaseType^);
　for i:=T^.MinValue to T^.MaxValue do
　begin
　　 s:= GetEnumName(TypeInfo , i);
　　if s<>'' then str.Add(s) else break;
　end;
end;

使い方
GetEnumNameList(TypeInfo(TAlign) , RadioGroup1.Items) ;