Des DLL pour Panoramic ?

1. La DLL est chargée en mémoire par l'instruction :

dll_on "xxx.dll"

où xxx.dll est le nom de la bibliothèque. Quand la DLL n'est plus nécessaire, la mémoire peut être libérée par l'instruction dll_off

2. La syntaxe d'appel d'une fonction de DLL est de la forme :

result% = dll_calln("DllFunctionName", par1%, ..., parn%)

où n est un entier de 0 à 6 qui représente le nombre de paramètres passés à la fonction. Il y a en fait 7 routines différentes :

dll_call0("DllFunctionName")
dll_call1("DllFunctionName", par1%)
dll_call2("DllFunctionName", par1%, par2%)
..........................................

Le premier paramètre est une chaîne contenant le nom de la fonction appelée. Il est suivi par les paramètres de la fonction, qui sont théoriquement de type entier mais peuvent être des adresses, ce qui permet de passer des nombres réels ou des chaînes de caractères (voir paragraphe 3).

Notez aussi que :

* PANORAMIC ne peut appeler que des fonctions dans une DLL, pas de sous-programmes.

* Toute fonction appelée par dll_call doit retourner une valeur entière.

3. Les paramètres entiers peuvent être passés par valeur ou par référence. Dans ce dernier cas, on utilise la fonction adr() de PANORAMIC.

4. Les nombres réels sont obligatoirement passés par référence. Il en est de même pour les chaînes de caractères. Dans ce dernier cas cependant, le paramètre de la fonction appelée doit être un pointeur sur une chaîne à zéro terminal.

5. Les chaînes de caractères passées aux fonctions de la DLL doivent être dimensionnées à une longueur suffisante dans le programme appelant. C'est particulièrement important si la chaîne est modifiée par la DLL, car alors sa longueur peut varier.

6. Au stade actuel du développement de PANORAMIC, aucun tableau ne peut être passé, ni par valeur ni par référence avec adr().

7. L'appel des fonctions doit se faire selon la convention stdcall.

8. Le nom de la fonction appelée ("DllFunctionName") doit respecter les majuscules et les minuscules.

dim entiers%(10), flottants(15), res%
...
res% = dll_call2("TestDesTableaux",adr(entier%),adr(flottant))

dim entiers2%(5,20), res%
...
res% = dll_call1("AutreTest",adr(entiers2%))

// fonction compatible avec la version compilée de PANORAMIC
//   par = identifiant de destination   soit ADR(s$)    soit HANDLE(memo%)
// Cette fonction prend des données string à partit d'un sgtring Panoramic,
// mais aussi le contenu d'un MEMO ou d'un LIST dont on a passé le handle en paramètre,
// et elle gère les particularités de Panoramic compilé.
  function GetStringFromPanoramic(par: integer): string;
  var
    n, Len, cnt, i: integer;
    memo: TMemo;
    lb: TListBox;
    s1, s2: string;
    control: TWinControl;
    pb: pbyte;
    pi: pinteger;

    function GetClassName(Handle: THandle): String;
    var
      Buffer: array[0..MAX_PATH] of Char;
    begin
      Windows.GetClassName(Handle, @Buffer, MAX_PATH);
      Result := String(Buffer);
    end;

  begin
    result := '';
    if par=0 then exit;
    try
      memo := TMemo(par);
      if memo.ClassName='TMemo' then begin
        result := memo.Text;
        exit;
      end;
    except
    end;

    try
      if GetClassName(par)='TMemo' then begin

        Len := SendMessage(par, WM_GETTEXTLENGTH, 0, 0);
        if Len>0 then begin
          SetLength(s1, Len+1);
          Len := SendMessage(par, WM_GETTEXT, Len+1, LPARAM(PChar(s1)));
          delay(100);
          SetLength(s1, Len);
        end;

        result := Trim(s1);
        exit;
      end;
    except
    end;

    try
      if GetClassName(par)='TListBox' then begin

        cnt := SendMessage(par, LB_GETCOUNT, 0, 0);
        s1 := '';
        if cnt<>LB_ERR then begin
          for i:=0 to cnt-1 do begin
            s2 := '';
            Len := SendMessage(par, LB_GETTEXTLEN, i, 0);
            if Len>0 then begin
              SetLength(s2, Len+1);
              SendMessage(par, LB_GETTEXT, i, LPARAM(PChar(s2)));
              delay(100);
              s1 := s1 + Trim(s2) + #13#10;
            end;
          end;
        end;

        result := Trim(s1);
        exit;
      end;
    except
    end;

    if PCompiledMode then begin
      cnt := 0;
{$if StringParameterMethod=1}
      pb := pbyte(par);                         // méthode V1 (Jack): ADR(s$) pointe vers l'adresse du premier caractère
{$else}
      if pinteger(par)^<>0 then begin
        pb := pbyte(pinteger(par)^);              // méthode V2 (Jack): ADR(s$) pointe vers un mot contenant l'adresse du premier caractère
{$ifend}
        while pb^<>0 do begin
          inc(pb);
          inc(cnt);
        end;
      end;
      SetLength(result,cnt);
      if cnt>0 then begin
        pb := pbyte(pinteger(par)^);
        for i:=1 to cnt do begin
          result[i] := chr(pb^);
          inc(pb);
        end;
      end;
    end else begin
      result := pstring(par)^;
    end;
  end;

// procédure compatible avec la version compilée de PANORAMIC
//   s   = string (éventuellement multi-ligne) à envoyer à Panoramic
//   par = identifiant de destination   soit ADR(s$)    soit HANDLE(memo%) soit handle(list%)
  procedure CopyStringToPanoramic(s: string; par: integer);
  var
    p1, p2: pchar;
    n, p: integer;
    memo: TMemo;
    s1, s2: string;
    control: TWinControl;
    pi, po: pbyte;
    zero: byte;

    function GetClassName(Handle: THandle): String;
    var
      Buffer: array[0..MAX_PATH] of Char;
    begin
      Windows.GetClassName(Handle, @Buffer, MAX_PATH);
      Result := String(Buffer);
    end;

  begin
    if par=0 then exit;
    try
      memo := TMemo(par);
      if memo.ClassName='TMemo' then begin
        s1 := s;
        memo.Text := trim(s1+' ');
        exit;
      end;
    except
    end;

    try
      if GetClassName(par)='TMemo' then begin
        s1 := s;
        SendMessage(par,WM_SETTEXT,0,integer(pchar(s1)));
        exit;
      end;
    except
    end;

    try
      if GetClassName(par)='TListBox' then begin
        SendMessage(par,LB_RESETCONTENT,0,0);
        s1 := s + #13#10;
        while s1<>'' do begin
          p := pos(#13#10,s1);
          if p>0 then begin
            s2 := LeftStr(s1,p-1);
            s1 := MidStr(s1,p+2,Length(s1));
            SendMessage(par,LB_ADDSTRING,0,integer(pchar(s2)));
          end;
        end;
        if s1<>'' then SendMessage(par,LB_ADDSTRING,0,integer(pchar(s1)));
        exit;
      end;
    except
    end;

    zero := 0;
    p1 := @zero;
    n := length(s);
    if n>0 then p1 := @s[1];
    if PCompiledMode then begin
      // mode compilé
      pi := pbyte(@s[1]);
{$if StringParameterMethod=1}
      po := pbyte(par);                         // méthode V1 (Jack): ADR(s$) pointe vers l'adresse du premier caractère
{$else}
      po := pbyte(pinteger(par)^);              // méthode V2 (Jack): ADR(s$) pointe vers un mot contenant l'adresse du premier caractère
{$ifend}
      while po^<>0 do begin
        if pi^<>0 then begin
          po^ := pi^;
          inc(po);
          inc(pi);
        end else begin
          po^ := 32;
          inc(po);
        end;
      end;
    end else begin
      //mode interprété
      if n>0 then p1 := pchar(@s[1]);
      p2 := pchar(pinteger(par)^);
      while p2^<>#0 do begin
        if n>0 then begin
                 if p1<>#0 then p2^ := p1^
                           else dec(p2);
               end else begin
                 p2^ := #32;
               end;
        inc(p1);
        inc(p2);
        dec(n);
      end;
    end;
  end;

// Cette procédure écrit une chaîne de caractères dans un sgtring Panoramic en le remplaçant partiellement
  procedure CopyStringOverPanoramicString(sIn: string; offs,sOut: integer);
  var
    cnt: integer;
    pi, po: pbyte;
  begin

    if PCompiledMode then begin
      cnt := 0;
      pi := pbyte(@sIn[1]);
{$if StringParameterMethod=1}
      po := pbyte(sOut+offs);
{$else}
      if sIn<>'' then begin
        po := pbyte(pinteger(sOut)^+offs);
{$ifend}
        while (pi^<>0) and (po^<>0) do begin
          po^ := pi^;
          inc(pi);
          inc(po);
        end;
      end;
    end else begin
      pi := pbyte(@sIn[1]);
      po := pbyte(pinteger(sOut)^+offs);
      while (pi^<>0) and (po^<>0) do begin
        po^ := pi^;
        inc(pi);
        inc(po);
      end;
    end;


  end;

function strcmp% (a$, b$)
' Comparaison de 2 chaines de caracteres
  
  if a = b then
    return 0
  elseif a > b then
    return 1
  else
    return -1
  end_if
end_function

extern "Windows-MS"

function strcmp(byref p_a as zstring ptr, byref p_b as zstring ptr) as long export
  dim as string a = *p_a
  dim as string b = *p_b

' Comparaison de 2 chaines de caracteres
  
  if a = b then
    return 0
  elseif a > b then
    return 1
  else
    return -1
  end if

  *p_a = a
  *p_b = b
end function

extern "Windows-MS"

function init_array (p as long ptr, byval n as long) as long export

  for i as long = 0 to n
    p[i] = i
  next i

  return n + 1  ' Nb d'elements
end function

end extern

dll_on "C:\FBCroco\exemples\lib\panoramic\array.dll"

dim a%(10), res%, i%

res% = dll_call2("init_array", adr(a%), 10)

for i% = 0 to 10
  print a%(i%)
next i%  

print : print res%, " elements"

end

extern "Windows-MS"

function init_array (p as long ptr, byval n1 as long, byval n2 as long) as long export

  for i as long = 0 to (n1 + 1) * (n2 + 1) - 1
    p[i] = i
  next i

  return (n1 + 1) * (n2 + 1)  ' Nb d'elements
end function

end extern

dll_on "C:\FBCroco\exemples\lib\panoramic\array.dll"

dim a%(3,4), res%, i%, j%
                                                                      
res% = dll_call3("init_array", adr(a%), 3, 4)

for i% = 0 to 3
  for j% = 0 to 4
    print a%(i%,j%)
  next j%
  print  
next i%
  
print : print res%, " elements"

end

// copier un tableau de type integer de Panoramic dans un tableau dynamique Delphi dans la DLL
function GetIntegerArrayFromPanoramic(aIntegerArray: pinteger; nDimension: integer): integer; stdcall; export;
var
  IntegerArray: array of Integer;
  i: integer;
  pi: pinteger;
begin
  result := -1;
  try
    if aIntegerArray=nil then exit;            // il faut au moins une adresse
    if nDimension<0 then exit;                // il faut une dimenion Panoramic valide
    SetLength(IntegerArray,nDimension+1);      // affecter la mémoire
    pi := aIntegerArray;                      // boucle de lecture
    for i:=0 to nDimension do begin
      IntegerArray[i] := pi^;                  // ccpier un élément
      inc(pi);                                // ajuster le pointeur
showmessage(format('%d: %d',[i,IntegerArray[i]]));  // juste pour montrer le résultat - ligne à supprimer !
    end;
    result := 0;
  except
  end;
end;
exports GetIntegerArrayFromPanoramic;

// copier un tableau de type integer d'un tableau dynamique Delphi dans la DLL vers un tableau dans Panoramic
function SetIntegerArrayFromPanoramic(aIntegerArray: pinteger; nDimension: integer): integer; stdcall; export;
var
  IntegerArray: array of Integer;
  i: integer;
  pi: pinteger;
begin
  result := -1;
  try
    if aIntegerArray=nil then exit;                  // il faut au moins une adresse
    if nDimension<0 then exit;                      // il faut une dimenion Panoramic valide

    // les 2 lignes suivantes sont là pour "simuler" un tableau existant dans la DLL...
    SetLength(IntegerArray,nDimension+1);            // affecter la mémoire
    for i:=0 to nDimension do IntegerArray[i] := i*2;

    if nDimension>=Length(IntegerArray) then exit;  // trop de données demandées ?
    pi := aIntegerArray;                            // boucle d'écriture
    for i:=0 to nDimension do begin
      pi^ := IntegerArray[i];                          // ccpier un élément
      inc(pi);                                        // ajuster le pointeur
showmessage(format('%d: %d',[i,IntegerArray[i]]));  // juste pour montrer le résultat - ligne à supprimer !
    end;
    result := 0;
  except
  end;
end;
exports SetIntegerArrayFromPanoramic;

// copier un tableau de type float de Panoramic dans un tableau dynamique Delphi dans la DLL
function GetFloatArrayFromPanoramic(aFloatArray: pfloat; nDimension: integer): integer; stdcall; export;
var
  FloatArray: array of double;
  i: integer;
  pf: pfloat;
begin
  result := -1;
  try
    if aFloatArray=nil then exit;              // il faut au moins une adresse
    if nDimension<0 then exit;                // il faut une dimenion Panoramic valide
    SetLength(FloatArray,nDimension+1);        // affecter la mémoire
    pf := aFloatArray;                        // boucle de lecture
    for i:=0 to nDimension do begin
      FloatArray[i] := pf^;                      // ccpier un élément
      inc(pf);                                  // ajuster le pointeur
showmessage(format('%d: %f',[i,FloatArray[i]]));  // juste pour montrer le résultat - ligne à supprimer !
    end;
    result := 0;
  except
  end;
end;
exports GetFloatArrayFromPanoramic;

// copier un tableau de type float d'un tableau dynamique Delphi dans la DLL vers un tableau dans Panoramic
function SetFloatArrayFromPanoramic(aFloatArray: pfloat; nDimension: integer): integer; stdcall; export;
var
  FloatArray: array of double;
  i: integer;
  pf: pfloat;
begin
  result := -1;
  try
    if aFloatArray=nil then exit;                    // il faut au moins une adresse
    if nDimension<0 then exit;                      // il faut une dimenion Panoramic valide

    // les 2 lignes suivantes sont là pour "simuler" un tableau existant dans la DLL...
    SetLength(FloatArray,nDimension+1);              // affecter la mémoire
    for i:=0 to nDimension do FloatArray[i] := i*2.002;

    if nDimension>=Length(FloatArray) then exit;    // trop de données demandées ?
    pf := aFloatArray;                              // boucle de lecture
    for i:=0 to nDimension do begin
      pf^ := FloatArray[i];                            // ccpier un élément
      inc(pf);                                        // ajuster le pointeur
showmessage(format('%d: %f',[i,FloatArray[i]]));  // juste pour montrer le résultat - ligne à supprimer !
    end;
    result := 0;
  except
  end;
end;
exports SetFloatArrayFromPanoramic;

// trouver et mémoriser l'adresse de début de la table de symboles Panoramic
function LocalizePanoramicSymbolTable(a: integer):integer; stdcall; export;
{
  Pour tomber sur le début d'une entrée de table de symbole (pointeur vers le nom),
  il faut calculer adr(variable)-delta
  avec delta=12 pour un entier et delta=24 pour un flottant.
  Donc, cette fonction suppose être appelée avec adr(number_click). Cette variable
  est toujours définie et est de type flottant. Ensuite, chaque entrée dans la
  table de synboles a une longueur de 80 ou 4*26 caractères (50 hexa).

  Pour les tableaux, on sait les éléments suivants;
  - dim t%(3)  t% n'est pas dans la table de symbole de base
  - dim t%(3)  adr(t%) pointe vers la liste des éléments t%(0),t%(1),t%(2),t%(3)

  Une entrée dans la table de symboles Panoramic a la structure suivante:
    mot  offset  utilisation
    ----------------------------------------------------------------------------
    0      0    adresse du nom sous forme de chaîne de caractères (majuscules)
    1      4    type de variable (1...9)
    2      8
    3    12    valeur entière si type=1
    4    16
    5    20
    6    24    valeur flottante si type=3 (premier mot)
    7    28    valeur flottante si type=3 (deuxième mot)
    8    32    dimension 1 si type=4 ou type=7: nombre de segments utilisés de ce type + 1
    9    36    dimension 1 si type=5 ou type=8: nombre de segments utilisés de ce type + 1
    10    40    dimension 1 si type=6 ou type=9: nombre de segments utilisés de ce type + 1
    11    44    dimension 1 si type=4: nombre de segments utilisés de ce type + 1
    12    48    dimension 1 si type=8: nombre de segments utilisés de ce type + 1
    13    52    dimension 1 si type=9: nombre de segments utilisés de ce type + 1
    14    56    dimension 1 si type=4 ou type=7
    15    60    dimension 1 si type=5 ou type=8
    16    64    dimension 1 si type=6 ou type=9
    17    68    dimension 2 si type=7
    18    72    dimension 2 si type=8
    19    76    dimension 2 si type=9

  Types:
    1  entier simple
    2  flottant simple
    3  chaîne de caractères simple
    4  tableau d'entiers en une dimension
    5  tableau de flottants en une dimension
    6  tableau de chaînes de caractères en une dimension
    7  tableau d'entiers en deux dimensions
    8  tableau de flottants en deux dimensions
    9  tableau de chaînes de caractères en deux dimensions


}
var
  pi1: pinteger;
begin
  pi1 := pinteger(a-24);
  while pi1^<>0 do pi1 := pinteger(integer(pi1)-4*PanoramicSymbolTableEntrySize);
  pi1 := pinteger(integer(pi1)+4*PanoramicSymbolTableEntrySize);
  PanoramicSymbolTable := pi1;
  result := integer(PanoramicSymbolTable);
{$ifdef debugit}
showmessage('LocalizePanoramicSymbolTable: PanoramicSymbolTable='+inttostr(result)+'  '+inttohex(result,8));
{$endif}
end;
exports LocalizePanoramicSymbolTable;

// Cette fonction retourne l'adresse du début de la table des variables de Panoramic.
// Elle doit être appelée avec l'adresse d'une variable système en format flottant,
// comme NUMBER_CLICK par exemple.
function FindSymbolTableStartAddress(a_number_click: pinteger):integer; stdcall; export;
var
  ptr: pinteger;
begin
  result := integer(PanoramicSymbolTable);
  exit;

  result := 0;                // supposer "erreur"
  ptr := a_number_click;
  inc(ptr,-6);                // pointer sur l'adresse du nom de NUMBER_CLICK
  if pstring(ptr)^='NUMBER_CLICK' then begin
    while ptr^<>0 do inc(ptr,-PanoramicSymbolTableEntrySize);
    inc(ptr,PanoramicSymbolTableEntrySize);
    result := integer(ptr);
  end;
end;
exports FindSymbolTableStartAddress;

' test_accès_tableaux.bas

dim res%, entiers%(5), flottants(7), i%

for i%=0 to 5
  entiers%(i%) = i%+100*i%
next i%
for i%=0 to 7
  flottants(i%) = 1/(i%+1)
next i%

dll_on "KGF.dll"

res% = dll_call2("GetIntegerArrayFromPanoramic",adr(entiers%),5)
res% = dll_call2("SetIntegerArrayFromPanoramic",adr(entiers%),5)
for i%=0 to 5
  message "SetIntegerArrayFromPanoramic  "+str$(i%)+": "+str$(entiers%(i%))
next i%

res% = dll_call2("GetFloatArrayFromPanoramic",adr(flottants),7)
res% = dll_call2("SetFloatArrayFromPanoramic",adr(flottants),7)
for i%=0 to 7
  message "SetFlottantArrayFromPanoramic  "+str$(i%)+": "+str$(flottants(i%))
next i%

end

// copier un tableau de type integer de Panoramic dans un tableau dynamique Delphi dans la DLL
function GetIntegerArrayFromPanoramic(aIntegerArray: pinteger; nDimension: integer): integer; stdcall; export;
var
  IntegerArray: array of Integer;
  i: integer;
  pi: pinteger;
begin
  result := -1;
  try
    if aIntegerArray=nil then exit;            // il faut au moins une adresse
    if nDimension<0 then exit;                 // il faut une dimenion Panoramic valide
    SetLength(IntegerArray,nDimension+1);      // affecter la mémoire
    pi := aIntegerArray;                       // boucle de lecture
    for i:=0 to nDimension do begin
      IntegerArray[i] := pi^;                  // ccpier un élément
      inc(pi);                                 // ajuster le pointeur
showmessage(format('GetIntegerArrayFromPanoramic  %d: %d',[i,IntegerArray[i]]));   // juste pour montrer le résultat - ligne à supprimer !
    end;
    result := 0;
  except
  end;
end;
exports GetIntegerArrayFromPanoramic;

// copier un tableau de type integer d'un tableau dynamique Delphi dans la DLL vers un tableau dans Panoramic
function SetIntegerArrayFromPanoramic(aIntegerArray: pinteger; nDimension: integer): integer; stdcall; export;
var
  IntegerArray: array of Integer;
  i: integer;
  pi: pinteger;
begin
  result := -1;
  try
    if aIntegerArray=nil then exit;                  // il faut au moins une adresse
    if nDimension<0 then exit;                       // il faut une dimenion Panoramic valide

    // les 2 lignes suivantes sont là pour "simuler" un tableau existant dans la DLL...
    SetLength(IntegerArray,nDimension+1);            // affecter la mémoire
    for i:=0 to nDimension do IntegerArray[i] := i*2;

    if nDimension>=Length(IntegerArray) then exit;   // trop de données demandées ?
    pi := aIntegerArray;                             // boucle d'écriture
    for i:=0 to nDimension do begin
      pi^ := IntegerArray[i];                          // ccpier un élément
      inc(pi);                                         // ajuster le pointeur
    end;
    result := 0;
  except
  end;
end;
exports SetIntegerArrayFromPanoramic;

// copier un tableau de type float de Panoramic dans un tableau dynamique Delphi dans la DLL
function GetFloatArrayFromPanoramic(aFloatArray: pfloat; nDimension: integer): integer; stdcall; export;
var
  FloatArray: array of double;
  i: integer;
  pf: pfloat;
begin
  result := -1;
  try
    if aFloatArray=nil then exit;              // il faut au moins une adresse
    if nDimension<0 then exit;                 // il faut une dimenion Panoramic valide
    SetLength(FloatArray,nDimension+1);        // affecter la mémoire
    pf := aFloatArray;                         // boucle de lecture
    for i:=0 to nDimension do begin
      FloatArray[i] := pf^;                      // ccpier un élément
      inc(pf);                                   // ajuster le pointeur
showmessage(format('GetFloatArrayFromPanoramic  %d: %f',[i,FloatArray[i]]));   // juste pour montrer le résultat - ligne à supprimer !
    end;
    result := 0;
  except
  end;
end;
exports GetFloatArrayFromPanoramic;

// copier un tableau de type float d'un tableau dynamique Delphi dans la DLL vers un tableau dans Panoramic
function SetFloatArrayFromPanoramic(aFloatArray: pfloat; nDimension: integer): integer; stdcall; export;
var
  FloatArray: array of double;
  i: integer;
  pf: pfloat;
begin
  result := -1;
  try
    if aFloatArray=nil then exit;                    // il faut au moins une adresse
    if nDimension<0 then exit;                       // il faut une dimenion Panoramic valide

    // les 2 lignes suivantes sont là pour "simuler" un tableau existant dans la DLL...
    SetLength(FloatArray,nDimension+1);              // affecter la mémoire
    for i:=0 to nDimension do FloatArray[i] := i*2.002;

    if nDimension>=Length(FloatArray) then exit;     // trop de données demandées ?
    pf := aFloatArray;                               // boucle de lecture
    for i:=0 to nDimension do begin
      pf^ := FloatArray[i];                            // ccpier un élément
      inc(pf);                                         // ajuster le pointeur
    end;
    result := 0;
  except
  end;
end;
exports SetFloatArrayFromPanoramic;

' Tableau_en_2_dimensions_avec_Panoramic_et_DLL.bas

dim res%, i%, j%, s$

' dim entiers%(5,3)
dim entiers%(6*4-1)     : ' les longueurs des dimensions sont 6 x 4 cases !

for i%=0 to 5
  for j%=0 to 3
    entiers(i%*100+j%,i%,j%)
  next j%
next i%

for i%=0 to 5
  s$ = ""
  for j%=0 to 3
    s$ = s$ + str$(fentiers%(i%,j%)) + "   "
  next j%
  print s$
next i%


end

' *** lire l'élément (i%,j%) du tableau entiers%
' ATTENTION: la fonction ne peut PAS avoir le même nom que le tableau !
'            Son nom est donc précédé d'un "f" pour signaler "fonction"
fnc fentiers%(i%,j%)
  result entiers%(i%*4+j%)     : ' la première dimension a une longueur de 6 !
end_fnc

' *** écrire la valeur v% dans l'élémént (i%,j%) du tableau entiers%
sub entiers(v%,i%,j%)
  entiers%(i%*4+j%) = v%
end_sub

{
  Objet MDA - Multi-DimensionalArray

  Cet objet permet de gérer des tableaux multi-dimensionnels simulés dans un tableau Panoramic uni-dimensionnel.
  L'intérêt de ce système est que les tableaux uni-dimensionnels peuvent facilement être passés en paramètre à la DLL.
  Ce n'est pas le cas des tableaux uni-dimensionnels.
  L'objet MDA est conçu pour donner accès aux fonctions d'une DLL aux données d'un tableau multi-dimensionnel de Panoramic.
  Pour cela, il faut déclarer en Panoramic un tableau uni-dimensionnel selon la formule:
        dim MonTableau((dim1+1) * (dim2+1) * (dim3+1) - 1)
  Exemple:
    dim MonTableau(5,3,7)
  sera remplacé par
    dim MonTableau(6*4*8-1)

  L'implémentation actuelle est prévue pour des tableaux jusqu'à 3 dimensions.

  Un tableau multi-dimensionnel doit être déclaré avec son nom et ses dimenions.
  L'objet MDA mémorise et gère toutes les déclarations ainsi que l'accès physique aux données.
  Deux fonctions exportées (accessibles en Panoramic) permettent définir les tableaux:
      res% = dll_call4("DefineMDA",adt(tableau$),d1%,d2%,d3%)    : ' crée ou modifie la déclaration d'un tableau
      res% = dll_call0("ResetMDA")                                : ' efface toutes les déclarations de tableaux
  Les fonctions et procédures suivantes sont utilisables dans la DLL (en Delphi), mais pas appelables par Panoramic:
      MDA.IndexOfArray(aName: string): string                    retourne l'index du tableau ou -1 si non déclaré
      MDA.TypeOfArray(aName: string): TypMDA                      retourne le type d'un tableau
      MDA.GetIntegerArrayElement(aIndex, d1,d2,d3: integer; aPanoramic: pinteger): integer    retourne le contenu d'un élément
      MDA.GetFloatArrayElement(aIndex, d1,d2,d3: integer; aPanoramic: pfloat): double          retourne le contenu d'un élément
      MDA.SetIntegerArrayElement(aIndex, d1,d2,d3: integer; aValue: integer; aPanoramic: pinteger)      remplace le contenu d'un élément
      MDA.SetFloatArrayElement(aIndex, d1,d2,d3: integer; aValue: double; aPanoramic: pfloat)          remplace le contenu d'un élément
}
type TypMDA = (tMDAundefined, tMDAfloat, tMDAinteger, tMDAstring);
type TMDA = class
  private
    fNames: array of string;
    fTypes: array of TypMDA;
    fDimensions: array of array of integer;
  published
    function IndexOfArray(aName: string): integer;
    function TypeOfArray(aName: string): TypMDA;
    function GetIntegerArrayElement(aIndex, d1,d2,d3: integer; aPanoramic: pinteger): integer;
    function GetFloatArrayElement(aIndex, d1,d2,d3: integer; aPanoramic: pfloat): double;
    procedure SetIntegerArrayElement(aIndex, d1,d2,d3: integer; aValue: integer; aPanoramic: pinteger);
    procedure SetFloatArrayElement(aIndex, d1,d2,d3: integer; aValue: double; aPanoramic: pfloat);
    procedure AddArray(aName: string; d1, d2, d3: integer);
    procedure ModifyArray(aName: string; d1, d2, d3: integer);
    constructor CreateNew;
    destructor Destroy;
end;

var
  MDA: TMDA;

Implementation

constructor TMDA.CreateNew;
begin
  inherited;
  SetLength(fNames,0);
  SetLength(fTypes,0);
  SetLength(fDimensions,0);
end;

destructor TMDA.Destroy;
begin
  SetLength(fNames,0);
  SetLength(fTypes,0);
  SetLength(fDimensions,0);
  inherited;
end;

function TMDA.IndexOfArray(aName: string): integer;
var
  i: integer;
begin
  result := -1;
  if Length(fNames)=0 then exit;
  for i:=0 to high(fNames) do begin
    if fNames[i]=aName then begin
      result := i;
      exit;
    end;
  end;
end;

function TMDA.TypeOfArray(aName: string): TypMDA;
var
  i: integer;
begin
  result := tMDAundefined;
  i := IndexOfArray(aName);
  if i>=0 then result := fTypes[i];
end;

function TMDA.GetIntegerArrayElement(aIndex, d1,d2,d3: integer; aPanoramic: pinteger): integer;
var
  pi: pinteger;
  offset: integer;
begin
  result := 0;
  if (aIndex<0) or (aIndex>high(fNames)) then exit;
  pi := aPanoramic;
  offset := d1*fDimensions[aIndex][1] + d2*fDimensions[aIndex][2] + d3;
  inc(pi,offset);
  result := pi^;
end;

function TMDA.GetFloatArrayElement(aIndex, d1,d2,d3: integer; aPanoramic: pfloat): double;
var
  pf: pfloat;
  offset: integer;
begin
  result := 0;
  if (aIndex<0) or (aIndex>high(fNames)) then exit;
  pf := aPanoramic;
  offset := d1*fDimensions[aIndex][1] + d2*fDimensions[aIndex][2] + d3;
  inc(pf,offset);
  result := pf^;
end;



procedure TMDA.SetIntegerArrayElement(aIndex, d1,d2,d3: integer; aValue: integer; aPanoramic: pinteger);
var
  pi: pinteger;
  offset: integer;
begin
  if (aIndex<0) or (aIndex>high(fNames)) then exit;
  pi := aPanoramic;
  offset := d1*fDimensions[aIndex][1] + d2*fDimensions[aIndex][2] + d3;
  inc(pi,offset);
  pi^ := aValue;
end;

procedure TMDA.SetFloatArrayElement(aIndex, d1,d2,d3: integer; aValue: double; aPanoramic: pfloat);
var
  pf: pfloat;
  offset: integer;
begin
  if (aIndex<0) or (aIndex>high(fNames)) then exit;
  pf := aPanoramic;
  offset := d1*fDimensions[aIndex][1] + d2*fDimensions[aIndex][2] + d3;
  inc(pf,offset);
  pf^ := aValue;
end;


procedure TMDA.AddArray(aName: string; d1, d2, d3: integer);
var
  i: integer;
begin
  i := Length(fNames);
  SetLength(fNames,i+1);
  SetLength(fTypes,i+1);
  SetLength(fDimensions,i+1);
  SetLength(fDimensions[i],3);
  fNames[i] := aName;
  fTypes[i] := tMDAfloat;
  if RightStr(aName,1)='%' then fTypes[i] := tMDAinteger;
  if RightStr(aName,1)='$' then fTypes[i] := tMDAstring;
  fDimensions[i][0] := d1;
  fDimensions[i][1] := d2;
  fDimensions[i][2] := d3;
end;

procedure TMDA.ModifyArray(aName: string; d1, d2, d3: integer);
var
  i: integer;
begin
  i := self.IndexOfArray(aName);
  fNames[i] := aName;
  fTypes[i] := tMDAfloat;
  if RightStr(aName,1)='%' then fTypes[i] := tMDAinteger;
  if RightStr(aName,1)='$' then fTypes[i] := tMDAstring;
  fDimensions[i][0] := d1;
  fDimensions[i][1] := d2;
  fDimensions[i][2] := d3;
end;

// cette fonction ajoute ou modifie la déclaration d'un tableau
function DefineMBA(aName: integer; d1, d2, d3: integer): integer; stdcall; export;
var
  s: string;
  index: integer;
begin
  result := -1;
  try
    if not assigned(MDA) then MDA := TMDA.CreateNew;                            // créer la table maître si besoin
    s := Trim(GetStringFromPanoramic(aName));                                  // prendre le nom Panoramic du tableau
    if s='' then exit;                                                          // nom manquant ?
    index := MDA.IndexOfArray(s);                                              // chercher le tableau dans la table maître
    if index<0 then begin                                                      // tableau pas encore enregistré ?
      MDA.AddArray(s,d1,d2,d2);                                                //  ajouter une nouvelle déclaration
    end else begin                                                              // tableau déjà enregistré - changer dimensions
      MDA.ModifyArray(s,d1,d2,d3);                                              //  modifier la définition du tableau
    end;
    result := 0;
  except
  end;
end;
exports DefineMBA;

// cette fonctiob efface toutes les déclarations de tableaux (PAS LES TABLEAUX !)
function ResetMDA: integer; stdcall; export;
begin
  result := -1;
  try
    if not assigned(MDA) then exit;
    MDA.Free;
    result := 0;
  except
  end;
end;
exports ResetMDA;