Section courante

A propos

Section administrative du site

L'instruction «DRAW» qu'utilisait la plupart des langages BASIC des ordinateurs des années 1980 était un outil très rapide pour faire des dessins, il est tout a fait dommage que de nos jours cette connaissance ce soit perdu. En revanche, voici le code Turbo Pascal pour Windows effectuant un dessin de «Boule» dans «Boule & Bill»:

  1. Program SamplesDraw;
  2.  
  3. Uses WinProcs, WinTypes;
  4.  
  5. Const
  6.  CrtWindow: HWnd = 0;
  7.  DrawS:Integer=4;
  8.  XL:Integer=160;
  9.  YL:Integer=100;
  10.  
  11. Var
  12.  DC: HDC;
  13.  PS: TPaintStruct;
  14.  Message: TMsg;
  15.  I:Byte;
  16.  N:String;
  17.  Mode:(_None_,_NoTrace_,_UnMove_);
  18.  a,b:Integer;
  19.  xc,yc:(NoMove,Add,Sub);
  20.  
  21. Function ExtractNm(S:String):Integer;
  22. Var
  23.  N:String;
  24.  a,b:Integer;
  25. Begin
  26.  N:='';
  27.  While(I<=Length(S))and(S[I] in ['0'..'9'])do Begin
  28.   N:=N+S[I];
  29.   Inc(I);
  30.  End;
  31.  If N=''Then a:=1
  32. Else Val(N,a,b);
  33.  ExtractNm:=a;
  34. End;
  35.  
  36. Function ExtractNmV(S:String):Integer;Begin
  37.  ExtractNmV:=ExtractNm(S)*(DrawS shr 2)
  38. End;
  39.  
  40. Procedure Line2(X,Y:Integer);Begin
  41.  If(Mode<>_NoTrace_)Then Begin
  42.   Case(xc)of
  43.    Add:Inc(X,XL);
  44.    Sub:X:=XL-X;
  45.   End;
  46.   Case(yc)of
  47.    Add:Inc(Y,YL);
  48.    Sub:Y:=YL-Y;
  49.   End;
  50.   If(YL=Y)and(X<XL)Then Begin
  51.    MoveTo(dc,X,YL);
  52.    LineTo(dc,XL,Y);
  53.   End
  54.    Else
  55.   Begin
  56.    MoveTo(dc,XL,YL);
  57.    LineTo(dc,X,Y);
  58.   End;
  59.  End;
  60. End;
  61.  
  62. Procedure SetPos(X,Y:Integer);Begin
  63.  Case(xc)of
  64.   Add:Inc(X,XL);
  65.   Sub:X:=XL-X;
  66.  End;
  67.  Case(yc)of
  68.   Add:Inc(Y,YL);
  69.   Sub:Y:=YL-Y;
  70.  End;
  71.  If(Mode<>_UnMove_)Then Begin
  72.   XL:=X;
  73.   YL:=Y;
  74.  End;
  75.  Mode:=_None_;
  76.  xc:=NoMove;
  77.  yc:=NoMove;
  78. End;
  79.  
  80. Procedure BasicDraw(S:String);Begin
  81.  I:=1;Mode:=_None_;
  82.  While I<=Length(S)do Begin
  83.   Inc(I);
  84.   Case S[I-1]of
  85.    'B':Mode:=_NoTrace_;
  86.    'C':{SetColor(dc,}ExtractNm(S){)};
  87.    'D':Begin
  88.     a:=ExtractNmV(S);
  89.     Line2(XL,YL+a);
  90.     SetPos(XL,YL+a);
  91.    End;
  92.    'E':Begin
  93.     a:=ExtractNmV(S);
  94.     Line2(XL+a,YL-a);
  95.     SetPos(XL+a,YL-a);
  96.    End;
  97.    'F':Begin
  98.     a:=ExtractNmV(S);
  99.     Line2(XL+a,YL+a);
  100.     SetPos(XL+a,YL+a);
  101.    End;
  102.    'G':Begin
  103.     a:=ExtractNmV(S);
  104.     Line2(XL-a,YL+a);
  105.     SetPos(XL-a,YL+a);
  106.    End;
  107.    'H':Begin
  108.     a:=ExtractNmV(S);
  109.     Line2(XL-a,YL-a);
  110.     SetPos(XL-a,YL-a);
  111.    End;
  112.    'L':Begin
  113.     a:=ExtractNmV(S);
  114.     Line2(XL-a,YL);
  115.     SetPos(XL-a,YL);
  116.    End;
  117.    'M':Begin
  118.     If S[I]in['+','-']Then Begin
  119.      If S[I]='+'Then xc:=Add else xc:=Sub;
  120.      Inc(I);
  121.     End;
  122.     a:=ExtractNm(S);
  123.     If S[I]=','Then Begin
  124.      Inc(I);
  125.      If S[I]in['+','-']Then Begin
  126.       If S[I]='+'Then yc:=Add else yc:=Sub;
  127.       Inc(I);
  128.      End;
  129.      b:=ExtractNm(S);
  130.     End
  131.      Else
  132.     b:=YL;
  133.     Line2(a,b);
  134.     SetPos(a,b);
  135.    End;
  136.    'N':Mode:=_UnMove_;
  137.    'R':Begin
  138.     a:=ExtractNmV(S);
  139.     Line2(XL+a,YL);
  140.     SetPos(XL+a,YL)
  141.    End;
  142.    'U':Begin
  143.     a:=ExtractNmV(S);
  144.     Line2(XL,YL-a);
  145.     SetPos(XL,YL-a)
  146.    End;
  147. ' ',';':;{C'est 2 caractŠres ne change rien en soit, donc...pas d'arrˆt!}
  148.    Else Exit;
  149.   End
  150.  End
  151. End;
  152.  
  153. Function CrtWinProc(Window: HWnd; Message, WParam: Word; LParam: LongInt): LongInt;Export;Begin
  154.  CrtWinProc := 0;
  155.  CrtWindow := Window;
  156.  Case Message of
  157.   wm_Paint:Begin
  158.    DC := BeginPaint(Window, PS);
  159.    BasicDraw('BM160,59M163,58M168,60M172,61M175,64M176,67M176,68M173,72 '+
  160.              'M168,75M164,76M160,77M156,75M152,73M150,72M149,68M151,63M157,59 '+
  161.              'M160,59');
  162.    BasicDraw('BM174,69M176,72M177,76M176,78M175,80M173,83M169,78M165,85 '+
  163.              'M166,85M163,86M160,87M152,85M148,86M144,85M139,85M137,83');
  164.    BasicDraw('BM150,72M148,77');
  165.    BasicDraw('BM135,83M139,84BM135,80M139,81');
  166.    BasicDraw('BM152,85M152,88M150,89M150,92');
  167.    BasicDraw('BM148,77M147,72M144,70M141,67M137,62M134,63M139,68M141,70M144,71');
  168.    BasicDraw('BM134,63M139,64BM138,62M131,66M130,64M135,59M133,59M129,61 '+
  169.              'M123,63M122,67M123,69M121,66M122,61BM118,64M117,66M120,70M122,71 '+
  170.              'M121,74M120,77M122,82M124,85M125,81M121,92M120,94M116,96M112,98 '+
  171.              'M108,100M104,102M102,104M99,107M97,111M97,114M98,116M100,120');
  172.    BasicDraw('BM100,120M102,122M104,124M108,126M112,127M116,126M120,123 '+
  173.              'M123,120M124,116M126,112M128,104M129,96M130,91M129,90M128,85M130,83 '+
  174.              'BM129,90 M134,91M136,92M141,89M144,91M146,93M142,94M148,99');
  175.    BasicDraw('BM148,99M152,95M157,93M156,91M151,92M146,93');
  176.    BasicDraw('BM144,80M146,77BM144,77M146,74M144,73BM140,78M142,77BM141,78E0 '+
  177.              'BM140,76M142,76M141,75M139,74M139,76BM137,77M135,75');
  178.    BasicDraw('BM141,75M139,72M136,71M134,71M133,72M134,73BM138,70M137,69 '+
  179.              'M138,67BM131,74M128,72M128,69M131,67M133,69M131,70M131,72M131,74');
  180.    BasicDraw('BM138,90M139,92M138,97M135,101M132,107M130,109M130,113M133,117 '+
  181.              'M136,118M142,116M144,114M148,111');
  182.    BasicDraw('BM148,99M147,103M147,106BM150,101M147,106M148,109M148,111 '+
  183.              'M152,113M155,112M153,108BM155,112M160,113M163,109M164,108BM157,93 '+
  184.              'M163,94M168,96');
  185.    BasicDraw('BM168,96M166,100M164,99M163,109M168,112M171,112M174,108M175,102 '+
  186.              'M180,98M176,95M172,93M170,93M168,96BM175,107M179,112M182,115M183,120 '+
  187.              'M182,123M181,126M180,128');
  188.    BasicDraw('BM179,98M180,101M177,102BM180,101M181,105M181,107M179,109M175,108');
  189.    BasicDraw('BM176,123M175,123M175,124M177,124M178,122');
  190.    BasicDraw('BM177,126M174,127M168,126M165,120M164,116M164,114');
  191.    BasicDraw('BM151,113M152,115M151,120M150,123');
  192.    BasicDraw('BM148,123M157,121M162,122M165,123M164,126M163,128M157,132 '+
  193.              'M172,129M177,130M180,133M176,139M167,142M160,144M146,141M144,138 '+
  194.              'M147,134M144,131M146,125M148,123');
  195.    BasicDraw('BM177,136M172,132BM176,140M172,136');
  196.    BasicDraw('BM145,128M141,126M143,123M141,125M141,120M140,125M139,120 '+
  197.              'M139,124M135,123M137,126M135,131M136,134M140,136M144,137');
  198.    BasicDraw('BM182,123M185,124M184,126M182,127M187,130M187,133M183,137 M176,139');
  199.    EndPaint(Window, PS);
  200.   End;
  201.   wm_Destroy: PostQuitMessage(0);
  202.   Else CrtWinProc := DefWindowProc(Window, Message, WParam, LParam);
  203.  End;
  204. End;
  205.  
  206. Const
  207.  CrtClass: TWndClass = (
  208.   style: cs_HRedraw + cs_VRedraw;
  209.   lpfnWndProc: @CrtWinProc;
  210.   cbClsExtra: 0;
  211.   cbWndExtra: 0;
  212.   hInstance: 0;
  213.   hIcon: 0;
  214.   hCursor: 0;
  215.   hbrBackground: 0;
  216.   lpszMenuName: NIL;
  217.   lpszClassName: 'TPWDraw'
  218.  );
  219.  
  220. BEGIN
  221.  If HPrevInst = 0 Then Begin
  222.   CrtClass.hInstance := HInstance;
  223.   CrtClass.hIcon := LoadIcon(0, idi_Application);
  224.   CrtClass.hCursor := LoadCursor(0, idc_Arrow);
  225.   CrtClass.hbrBackground := color_Window + 1;
  226.   RegisterClass(CrtClass);
  227.  End;
  228.  xc:=NoMove;yc:=NoMove;
  229.  CrtWindow := CreateWindow(
  230.   CrtClass.lpszClassName,
  231.   'Dessin Boule et Bill',
  232.   ws_OverlappedWindow + ws_HScroll + ws_VScroll,
  233.   cw_UseDefault, cw_UseDefault,
  234.   cw_UseDefault, cw_UseDefault,
  235.   0,0,
  236.   HInstance,
  237.   NIL
  238.  );
  239.  ShowWindow(CrtWindow, CmdShow);
  240.  UpdateWindow(CrtWindow);
  241.  While GetMessage(Message, 0, 0, 0) do Begin
  242.   TranslateMessage(Message);
  243.   DispatchMessage(Message);
  244.  End;
  245. END.

Voici en terminant un exemple du résultat de se petit programme :




Dernière mise à jour : Dimanche, le 10 décembre 2017