搜索
bottom↓
回复: 16

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

[复制链接]

出0入4汤圆

发表于 2007-11-9 17:31:52 | 显示全部楼层 |阅读模式
{
    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 [0..600] OF BYTE;
  LineX                                  : array [0..100,0..600] OF INTEGER;
const
    SX : array [0..7] OF SHORTINT=(-1, 0, 1, 1, 1, 0,-1,-1);
    SY : array [0..7] OF SHORTINT=(-1,-1,-1, 0, 1, 1, 1, 0);
type
    arrayType = array[1..50] 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[Right] < V) do
        inc(Right);
      while (A[Left] > V) do
        Dec(Left);
      if (Right <= Left) then
        begin
          Temp:=A[Left];
          A[Left]:=A[Right];
          A[Right]:=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[P1] ;
     if Len >= 2 then
      begin
        for P2:=1 to Len do
          Darray[P2]:=LineX[P2,P1] ;
        if Len > 2 then
          Partition(Darray,1,len);
        P2:=1;
        repeat
          P3:= Darray[P2] ; P4:= Darray[P2 + 1];
          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[LastOperation];
        SearchPoint.Y:=ActualPoint.Y+Sy[LastOperation];
        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[ActualPoint.Y]:=LineY[ActualPoint.Y]-1;
                    MerkY:= ActualPoint.Y ;
                    LineY[SearchPoint.Y]:=LineY[SearchPoint.Y]+1;
                  end ;
                LineX[LineY[SearchPoint.Y],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.


上面是一个例子,Free Pascal 可以运行在各个平台之上,而且是自由软件。

阿莫论坛20周年了!感谢大家的支持与爱护!!

一只鸟敢站在脆弱的枝条上歇脚,它依仗的不是枝条不会断,而是自己有翅膀,会飞。

出0入4汤圆

 楼主| 发表于 2007-11-9 21:39:47 | 显示全部楼层
晚上回来搜到一篇文章:http://www.cnblogs.com/Chinasf/archive/2006/08/12/474816.html

文章中还有几幅图。

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

出0入4汤圆

 楼主| 发表于 2007-11-11 11:20:55 | 显示全部楼层
看来我这个建议确实是够糟糕的,都没有朋友回复,哈哈。

去书城之前,下载安装了一下 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 语言!

出0入4汤圆

 楼主| 发表于 2007-11-11 11:29:22 | 显示全部楼层
运行 OpenGL demo 的截屏:

出0入4汤圆

 楼主| 发表于 2007-11-11 15:24:33 | 显示全部楼层
我对 Pascal 一点都不懂,开始读这份文档入门:
http://taoyue.com/tutorials/pascal/
头像被屏蔽

出0入0汤圆

发表于 2007-11-11 17:22:42 | 显示全部楼层
好。谢谢! COOL !

出0入0汤圆

发表于 2007-11-11 21:50:28 | 显示全部楼层
lz太酷了,但是干嘛不用wxwidgets呢?一样的跨平台啊。
是真正意义上的“一行代码都不需改动”的跨平台的界面编程

出0入4汤圆

 楼主| 发表于 2007-11-11 22:08:44 | 显示全部楼层
wxwidgets 只是听说过啊,主要是被这个名字给吓坏了,这个东西以后再搞。
混了几年了,第一次穿裤子,呵呵。

PS:正在埋头学 Pascal。

出0入0汤圆

发表于 2007-11-11 22:13:14 | 显示全部楼层
偶用Vc6编译一次wxwidgets库,两个多小时,郁闷啊

出0入4汤圆

 楼主| 发表于 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.

出0入0汤圆

发表于 2007-11-27 21:41:13 | 显示全部楼层
看了这么多atommann发的linux的帖子,看来atommann已经彻底告别了windows!!
赞一个!!!
头像被屏蔽

出0入0汤圆

发表于 2007-11-27 21:46:44 | 显示全部楼层
唉,我们的网站服务器正好相反,从 redhat LINUX 转投到了windows 2003 64-bit 的阵营了。 主要是太省事了 :)

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

出0入0汤圆

发表于 2007-11-27 22:53:55 | 显示全部楼层
支持楼主一个,偶喜欢优雅的Pascal

出0入0汤圆

发表于 2007-11-28 07:05:18 | 显示全部楼层
windows 2003 64-bit 要多少银子一套!?阿莫的不会是D版的吧!

出0入0汤圆

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

出0入0汤圆

发表于 2008-1-26 23:47:05 | 显示全部楼层
Pascal如果能够做到规范书写,可读性优于C家族,尤其对于新手来说,阅读Pascal程序要比C程序更容易理解,这也是为什么许多大学教材使用Pascal作为教学语言的原因。
另外,Pascal程序的安全性也优于C。

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

出0入0汤圆

发表于 2008-1-27 11:38:55 | 显示全部楼层
大学时候学算法用PASCAL,C语言自学
回帖提示: 反政府言论将被立即封锁ID 在按“提交”前,请自问一下:我这样表达会给举报吗,会给自己惹麻烦吗? 另外:尽量不要使用Mark、顶等没有意义的回复。不得大量使用大字体和彩色字。【本论坛不允许直接上传手机拍摄图片,浪费大家下载带宽和论坛服务器空间,请压缩后(图片小于1兆)才上传。压缩方法可以在微信里面发给自己(不要勾选“原图),然后下载,就能得到压缩后的图片】。另外,手机版只能上传图片,要上传附件需要切换到电脑版(不需要使用电脑,手机上切换到电脑版就行,页面底部)。
您需要登录后才可以回帖 登录 | 注册

本版积分规则

手机版|Archiver|amobbs.com 阿莫电子技术论坛 ( 粤ICP备2022115958号, 版权所有:东莞阿莫电子贸易商行 创办于2004年 (公安交互式论坛备案:44190002001997 ) )

GMT+8, 2024-3-29 05:47

© Since 2004 www.amobbs.com, 原www.ourdev.cn, 原www.ouravr.com

快速回复 返回顶部 返回列表