[一个糟糕的建议]用 Free Pascal 写充电器上位机程序 (amobbs.com 阿莫电子技术论坛) -

atommann 发表于 2007-11-9 17:31:52

[一个糟糕的建议]用 Free Pascal 写充电器上位机程序

{
This file is part of the Free Pascal run time library.
Copyright (c) 1993-98 by Gernot Tenchio

Mandelbrot Example using the Graph unit

See the file COPYING.FPC, included in this distribution,
for details about the copyright.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

**********************************************************************}
program mandel;
{$goto on}
{
Mandelbrot example using the graph unit.

Note: For linux you need to run this program as root !!
}

{$ifdef Win32}
{$apptype GUI}
{$endif}

uses
{$ifdef Win32}
WinCrt,
Windows,
{$endif}
dos,Graph;

{
const
shift:byte=12;
}

var
SearchPoint,ActualPoint,NextPoint    : PointType;
LastColor                            : longint;
Gd,Gm                               : smallint;
Max_Color,Max_X_Width,
Max_Y_Width,Y_Width                : word;
Y1,Y2,X1,X2,Dy,Dx                   : Real;
Zm                                  : Integer;
SymetricCase                               : boolean;
LineY                               : array OF BYTE;
LineX                               : array OF INTEGER;
const
SX : array OF SHORTINT=(-1, 0, 1, 1, 1, 0,-1,-1);
SY : array OF SHORTINT=(-1,-1,-1, 0, 1, 1, 1, 0);
type
arrayType = array of integer;

{------------------------------------------------------------------------------}
function ColorsEqual(c1, c2 : longint) : boolean;
begin
   ColorsEqual:=((GetMaxColor=$FF) and ((c1 and $FF)=(c2 and $FF))) or
      ((GetMaxColor=$7FFF) and ((c1 and $F8F8F8)=(c2 and $F8F8F8))) or
      ((GetMaxColor=$FFFF) and ((c1 and $F8FCF8)=(c2 and $F8FCF8))) or
      ((GetMaxColor>$10000) and ((c1 and $FFFFFF)=(c2 and $FFFFFF)));
end;

{------------------------------------------------------------------------------}
function CalcMandel(Point:PointType; z:integer) : Longint ;
var
x,y,xq,yq,Cx,Cy : real ;
begin
Cy:=y2 + dy*Point.y ;
Cx:=x2 + dx*Point.x ;
X:=-Cx ; Y:=-Cy ;
repeat
xq:=x * x;
yq:=y * y;
y :=x * y;
y :=y + y - cy;
x :=xq - yq - cx ;
z :=z -1;
until (Z=0) or (Xq + Yq > 4 );
if Z=0 Then
CalcMandel:=(blue and $FFFFFF)
else
CalcMandel:={DefaultColors[}(z mod Max_Color) + 1 {]};
end;

{-----------------------------------------------------------------------------}
procedure Partition(var A : arrayType; First, Last : Byte);
var
Right,Left : byte ;
V,Temp : integer;
begin
V := A[(First + Last) SHR 1];
Right := First;
Left := Last;
repeat
   while (A < V) do
   inc(Right);
   while (A > V) do
   Dec(Left);
   if (Right <= Left) then
   begin
      Temp:=A;
      A:=A;
      A:=Temp;
      Right:=Right+1;
      Left:=Left-1;
   end;
until Right > Left;
if (First < Left) then
   Partition(A, First, Left);
if (Right < Last) then
   Partition(A, Right, Last)
end;

{-----------------------------------------------------------------------------}
function BlackScan(var NextPoint:PointType) : boolean;
begin
BlackScan:=true;
repeat
if NextPoint.X=Max_X_Width then
   begin
   if NextPoint.Y < Y_Width then
      begin
         NextPoint.X:=0 ;
         NextPoint.Y:=NextPoint.Y+1;
      end
   else
      begin
         BlackScan:=false;
         exit;
      end ; { IF }
   end ; { IF }
NextPoint.X:=NextPoint.X+1;
until GetPixel(NextPoint.X,NextPoint.Y)=0;
end ;

{------------------------------------------------------------------------------}
procedure Fill(Ymin,Ymax,LastColor:integer);
var
P1,P3,P4,P : integer ;
Len,P2    : byte ;
Darray    : arraytype;
begin
SetColor(LastColor);
for P1:=Ymin+1 to Ymax-1 do
begin
Len:=LineY ;
if Len >= 2 then
   begin
   for P2:=1 to Len do
      Darray:=LineX ;
   if Len > 2 then
      Partition(Darray,1,len);
   P2:=1;
   repeat
      P3:= Darray ; P4:= Darray;
      if P3 <> P4 then
      begin
         line ( P3 , P1 , P4 , P1) ;
         if SymetricCase then
         begin
            P:=Max_Y_Width-P1;
            line ( P3 , P , P4 , P ) ;
         end;
      end; { IF }
      P2:=P2+2;
   until P2 >= Len ;
   end; { IF }
end; { FOR }
end;

{-----------------------------------------------------------------------------}
Function NewPosition(Last:Byte):Byte;
begin
newposition:=(((last+1) and 254)+6) and 7;
end;

{-----------------------------------------------------------------------------}
procedure CalcBounds;
var
lastOperation,KK,
Position                   : Byte ;
foundcolor                : longint;
Start,Found,NotFound       : boolean ;
MerkY,Ymax                : Integer ;
label
L;
begin
repeat
FillChar(LineY,SizeOf(LineY),0) ;
ActualPoint:=NextPoint;
LastColor:=CalcMandel(NextPoint,Zm) ;
putpixel (ActualPoint.X,ActualPoint.Y,LastColor);
if SymetricCase then
   putpixel (ActualPoint.X,Max_Y_Width-ActualPoint.Y,LastColor) ;
Ymax:=NextPoint.Y ;
MerkY:=NextPoint.Y ;
NotFound:=false ;
Start:=false ;
LastOperation:=4 ;
repeat
   Found:=false ;
   KK:=0 ;
   Position:=NewPosition(LastOperation);
   repeat
   LastOperation:=(Position+KK) and 7 ;
   SearchPoint.X:=ActualPoint.X+Sx;
   SearchPoint.Y:=ActualPoint.Y+Sy;
   if ((SearchPoint.X < 0) or
         (SearchPoint.X > Max_X_Width) or
         (SearchPoint.Y < NextPoint.Y) or
         (SearchPoint.Y > Y_Width)) then
      goto L;
   if (SearchPoint.X=NextPoint.X) and (SearchPoint.Y=NextPoint.Y) then
      begin
         Start:=true ;
         Found:=true ;
      end
   else
      begin
         FoundColor:=GetPixel(SearchPoint.X,SearchPoint.Y) ;
         if FoundColor = 0 then
         begin
            FoundColor:= CalcMandel (SearchPoint,Zm) ;
            Putpixel (SearchPoint.X,SearchPoint.Y,FoundColor) ;
            if SymetricCase then
               PutPixel (SearchPoint.X,Max_Y_Width-SearchPoint.Y,FoundColor) ;
         end ;
         if ColorsEqual(FoundColor,LastColor) then
         begin
            if ActualPoint.Y <> SearchPoint.Y then
               begin
               if SearchPoint.Y = MerkY then
                  LineY:=LineY-1;
               MerkY:= ActualPoint.Y ;
               LineY:=LineY+1;
               end ;
            LineX,SearchPoint.Y]:=SearchPoint.X ;
            if SearchPoint.Y > Ymax then Ymax:= SearchPoint.Y ;
               Found:=true ;
            ActualPoint:=SearchPoint ;
         end;
L:
         KK:=KK+1;
         if KK > 8 then
         begin
            Start:=true ;
            NotFound:=true ;
         end;
      end;
   until Found or (KK > 8);
until Start ;
if not NotFound then
   Fill(NextPoint.Y,Ymax,LastColor) ;
until not BlackScan(NextPoint);
end ;

{------------------------------------------------------------------------------
                           MAINROUTINE
------------------------------------------------------------------------------}
var
error,dummy : smallint;

var i,neededtime,starttime : longint;
hour, minute, second, sec100 : word;

const
count : longint = 1;
gmdefault = m640x480;

begin
gm:=-1;
if paramcount>0 then
begin
   val(paramstr(1),gm,error);
   if error<>0 then
      gm:=gmdefault;
{$ifdef go32v2}
   if paramcount>1 then
      begin
      Val(paramstr(2),count,error);
      if error<>0 then
         count:=1;
      end;
   if paramcount>2 then
      UseLFB:=true;
   if paramcount>3 then
      UseNoSelector:=true;
{$endif go32v2}
end;
gd:=d8bit;
if gm=-1 then
GetModeRange(gd,dummy,gm);
GetTime(hour, minute, second, sec100);
starttime:=((hour*60+minute)*60+second)*100+sec100;
{$ifdef Win32}
ShowWindow(GetActiveWindow,0);
{$endif}
InitGraph(gd,gm,'');
if GraphResult <> grOk then
begin
   Writeln('Graph driver ',gd,' graph mode ',gm,' not supported');
   Halt(1);
end;
for i:=1 to count do
begin
   Max_X_Width:=GetMaxX;
   Max_y_Width:=GetMaxY;
   Max_Color:=GetMaxColor-1;
   if Max_Color>255 then
   Max_Color:=255;
   ClearViewPort;

   x1:=-0.9;
   x2:= 2.2;
   y1:= 1.25;
   y2:=-1.25;
   zm:=90;
   dx:=(x1 - x2) / Max_X_Width ;
   dy:=(y1 - y2) / Max_Y_Width ;
   if abs(y1) = abs(y2) then
   begin
      SymetricCase:=true;
      Y_Width:=Max_Y_Width shr 1
   end
   else
   begin
      SymetricCase:=false;
      Y_Width:=Max_Y_Width;
   end;
   NextPoint.X:=0;
   NextPoint.Y:=0;
   LastColor:=CalcMandel(SearchPoint,zm);
   CalcBounds ;
end;
GetTime(hour, minute, second, sec100);
neededtime:=((hour*60+minute)*60+second)*100+sec100-starttime;
{$ifndef fpc_profile}
{$ifndef Win32}
readln;
{$else: Win32}
repeat
until keypressed;
{$endif}
{$endif fpc_profile}
CloseGraph;
{$ifndef Win32}
Writeln('Mandel took ',Real(neededtime)/100/count:0:3,' secs to generate mandel graph');
Writeln('With graph driver ',gd,' and graph mode ',gm);
{$endif}
end.

http://cache.amobbs.com/bbs_upload782111/files_8/ourdev_180363.png
上面是一个例子，Free Pascal 可以运行在各个平台之上，而且是自由软件。

atommann 发表于 2007-11-9 21:39:47

晚上回来搜到一篇文章：http://www.cnblogs.com/Chinasf/archive/2006/08/12/474816.html
http://cache.amobbs.com/bbs_upload782111/files_8/ourdev_180388.png
文章中还有几幅图。

文中提到一个叫 lazarus 的项目，见http://www.lazarus.freepascal.org/
很好玩啊。

atommann 发表于 2007-11-11 11:20:55

看来我这个建议确实是够糟糕的，都没有朋友回复，哈哈。./emotion/em073.gif

去书城之前，下载安装了一下 Lazarus，没想到这个词居然是“圣经中麻疯乞丐;穷人”之意，还找到一篇老文章：

Kylix的劲敌-开放源码的Lazarus
Lazarus 跟 Kylix 一样，是个 Pascal 的 RAD(快速程序发展环境)，它目前采用的是具有物件导向能力的 Free Pascal，目前 Lazarus 已经推出了最新版 0.7 版，其中除了整合发展环境(IDE)之外，还附加了一个强悍的转换工具 - SynEdit，可以将 Borland Delphi 的程序码直接转换到 Lazarus 上。　　就像是 Delphi 的 VCL 一样，Lazarus 也有丰富的物件程序库作为底层基础，称之为 LCL(Lazarus Class Libraries)，LCL 采用的是与 X Window 的 widget 无关的设计方式，因此无论是哪种 widget，使用 LCL 设计的软件只需同一套程序码就可以正确执行。　　目前 Lazarus 可以在 Linux 上执行，采用的是 GTK 程序库，理论上也可以在 Win32 上执行，唯一的问题出在 Win32 的 GTK+ 之间的相容性。目前 Lazarus 也正在发展采用 Qt 的版本，所以 KDE 版的 Lazarus 应该会在未来出现。　　Free Pascal 是 GPL 软件，它使用的 FCL(Free Pascal Class Libraries) 以及 Lazarus 所使用的 LCL 则是属於 LGPL版权声明，因此使用者可以用 Lazarus + Free Pascal 来设计商业软件。 Lazarus IDE 目前提供的功能包含了 : 　　Form Designer 　　Object Inspector 　　Editor Options 　　Compiler Options 　　Environment Options 　　Project Options 　　Code Completion 　　Syntax Highlighting Lazarus 的发展网址在 : http://www.lazarus.freepascal.org/。 Lazarus 的下载网址在 : ftp://lazarus.freepascal.org/lazarus/lazaruslinux.tar.gz。

-------------------------
Lazarus 的编译速度有点慢，不过作为 Freeware，我已经很满足了，准备开始学习 Pascal 语言！

atommann 发表于 2007-11-11 11:29:22

运行 OpenGL demo 的截屏：
http://cache.amobbs.com/bbs_upload782111/files_8/ourdev_180506.jpg

atommann 发表于 2007-11-11 15:24:33

我对 Pascal 一点都不懂，开始读这份文档入门：
http://taoyue.com/tutorials/pascal/

armok 发表于 2007-11-11 17:22:42

好。谢谢! COOL !

usbfish 发表于 2007-11-11 21:50:28

lz太酷了，但是干嘛不用wxwidgets呢？一样的跨平台啊。
是真正意义上的“一行代码都不需改动”的跨平台的界面编程

atommann 发表于 2007-11-11 22:08:44

wxwidgets 只是听说过啊，主要是被这个名字给吓坏了，这个东西以后再搞。
混了几年了，第一次穿裤子，呵呵。./emotion/em105.gif

PS：正在埋头学 Pascal。

usbfish 发表于 2007-11-11 22:13:14

偶用Vc6编译一次wxwidgets库，两个多小时，郁闷啊

atommann 发表于 2007-11-12 22:25:23

Tao Yue 的书看了2章了（计划每天晚上看1章），发现 Pascal 还是一种比较有意思的语言。
第二章的作业：求5个整数的和及平均值，并把结果写入一个文件。

(* The soluction of Chapter 2
Date: 2007-11-12
Who : Atommann
*)

program solution2;

const
number_of_integers = 5;

var
a, b, c, d, e : integer;
sum : integer;
average : real;
fileout : text;

begin
write ('Enter the first integer:');
readln (a);
write ('Enter the second integer:');
readln (b);
write ('Enter the third integer:');
readln (c);
write ('Enter the fouth integer:');
readln (d);
write ('Enter the fifth integer:');
readln (e);

sum := a + b + c + d + e;
average := sum / number_of_integers;

assign (fileout, 'c:\sum.txt');
rewrite (fileout);
writeln (fileout, '=== The additional solution to ===');
writeln (fileout, '===the problem of chapter 2===');

writeln (fileout, 'Number of integers = ', number_of_integers);
writeln (fileout, ''); (* A empty line *)

writeln (fileout, 'Number1:', a:8);
writeln (fileout, 'Number2:', b:8);
writeln (fileout, 'Number3:', c:8);
writeln (fileout, 'Number4:', d:8);
writeln (fileout, 'Number5:', e:8);
writeln (fileout, '================');
writeln (fileout, 'Sum:', sum:12);
writeln (fileout, 'Average:', average:10:1);

close (fileout);
end.

tsb0574 发表于 2007-11-27 21:41:13

看了这么多atommann发的linux的帖子，看来atommann已经彻底告别了windows！！
赞一个！！！

armok 发表于 2007-11-27 21:46:44

唉，我们的网站服务器正好相反，从 redhat LINUX 转投到了windows 2003 64-bit 的阵营了。主要是太省事了 :)

记得以前每次换一个LINUX新版本，折腾ORACLE的安装都需要一至二个月。想想真的恶梦啊。

avruser 发表于 2007-11-27 22:53:55

支持楼主一个，偶喜欢优雅的Pascal

ansion520 发表于 2007-11-28 07:05:18

windows 2003 64-bit 要多少银子一套!?阿莫的不会是D版的吧!./emotion/em035.gif

tywood 发表于 2008-1-26 18:16:42

pascal语言看起来费劲，在视觉上不直观，不能一眼看出层次，还有和C语言相比不够简洁，太啰嗦。我想这也是为什么C++，C##，java等比较新的语言都基本上采用了C语言的语法，而不是pascal的一个原因吧。当然pascal的不简洁不能怪它的发明人，毕竟它的出现要比C语言早，我想C语言的设计者也一定是受够了pascal的啰嗦才决定设计一个更加简洁的语言的吧:)

avruser 发表于 2008-1-26 23:47:05

Pascal如果能够做到规范书写，可读性优于C家族，尤其对于新手来说，阅读Pascal程序要比C程序更容易理解，这也是为什么许多大学教材使用Pascal作为教学语言的原因。
另外，Pascal程序的安全性也优于C。

C所以大行其道，是由于C更讨好程序员：首先C的书写更简洁和随意，打一对花括号要比begin...end少敲4下键盘，而且更容易写出有个性的、让人一时摸不着头脑的代码风格，这个特点很适合某些做技术的人喜欢标新立异的心理，既可以偷懒又可以卖弄。当然C还有一个优势是离硬件比较近，指针和操作绝对地址的能力使得C具有一定的汇编级别的能力，这个优势的反面是C的程序必需仔细书写，程序员要自己处理和规避许多代码中隐含的风险－－－这个特点同样更适合于在程序员中拉开档次。实际上有些人的观点C并不算完全的高级语言（C的硬件无关性比较差），但却是容易造就“高手”的语言。

ghost2 发表于 2008-1-27 11:38:55

大学时候学算法用PASCAL，C语言自学

页: [1]

amobbs.com 阿莫电子技术论坛's Archiver

[一个糟糕的建议]用 Free Pascal 写充电器上位机程序