{ $HDR$}
{**********************************************************************}
{ Copyrights:  GPL                                                     }
{**********************************************************************}
{ $ProjectName:Library$ }
{}
{ $Log:  53536: BarcodeApi.pas 
{
{   Rev 1.1    3/12/2001 10:59:14 AM  Michael
{ Allow for printing an already-checksummed barcode
}
{
{   Rev 1.0    16/11/2001 1:27:33 PM  michael
{ Initial Revision
}
unit BarcodeAPI;

{$A+}
{$B-}
{$H+}
{$J-}
{$T+}
{$X+}

interface

const

bcDefaultFlags = $00000000;

bcEncodingMask = $000000ff;  { 256 possibilites... }
bcNoAscii      = $00000100;  { avoid text in output }
bcNoChecksum   = $00000200;  { avoid checksum in output }
bcOnlyChecksum = $00000400;  { Only checksum output }

bcOutputMask   = $000ff000;  { 256 output types }
bcOutEps       = $00001000;
bcOutPS        = $00002000;
bcOutNoHeaders = $00100000;  { no header nor footer }

bc_Any  = 0;     { choose best-fit }
bc_EAN  = 1;
bc_UPC  = 2;     { upc = 12-digit ean }
bc_ISBN = 3;     { isbn numbers (still EAN13) }
bc_39   = 4;     { code 39 }
bc_128  = 5;     { code 128 (a,b,c: autoselection) }
bc_128C = 6;     { code 128 (compact form for digits) }
bc_128B = 7;     { code 128, full printable ascii }
bc_I25  = 8;     { interleaved 2 of 5 (only digits) }

BARCODE_DEFAULT_MARGIN = 10;

SHRINK_AMOUNT = 0.05; { shrink the bars to account for ink spreading }

type

TBarCodeType = (
    bcAny,     { choose best-fit }
    bcEAN,
    bcUPC,        { upc = 12-digit ean }
    bcISBN,       { isbn numbers (still EAN13) }
    bc39,         { code 39 }
    bc128,        { code 128 (a,b,c: autoselection) }
    bc128C,       { code 128 (compact form for digits) }
    bc128B,       { code 128, full printable ascii }
    bcI25,        { interleaved 2 of 5 (only digits) }
    bcWithChecksum
);

TBarCodeTypes = set of TBarCodeType;
  
type

TBarcode_Item = Record
    flags: Integer;         { type of encoding and decoding }
    ascii: PAnsiChar;       { malloced }
    partial: PAnsiChar;     { malloced too }
    textinfo: PAnsiChar;    { information about text positioning }
    encoding: PAnsiChar;    { code name, filled by encoding engine }
    width, height: Integer; { output units }
    xoff,yoff : Integer;    { output units }
    margin: Integer;        { output units }
    scalef: Double;     { requested scaling for barcode }
    error: Integer;         { an errno-like value, in case of failure }
    checksum : Integer;     { Checksum value}
end;

PBarcode_Item = ^TBarcode_Item;

// Canvas - output in Points. 
// 72 Points = 1 Inch
TBarcodeCanvas  = class
public
    procedure SetPenWidth( width: double); virtual; abstract;
    procedure DrawLine( X0, Y0, X1, Y1 : Double);  virtual; abstract;
    procedure SetFontSize( Size : Double);  virtual; abstract;
    procedure TextOut( X, Y : Double ; txt : string ); virtual; abstract;
end;       


TBarcode = class
public
    constructor Create(const txt : string);
    destructor Destory;

    procedure SetText( const txt : string);

    function Encode(CodeType :TBarCodeType; flags: Integer): integer; overload;
    function Encode(CodeTypes :TBarCodeTypes; flags: Integer): integer; overload;

    function Position(Width, Height, XOffset , YOffset : integer; ScaleFactor : double) : integer;

    function Draw(Canvas : TBarcodeCanvas ) : integer;

    function Version:string;
    function IntVersion: integer;
private
    FBC : PBarcode_Item;

end;

// Create and destroy barcode structures
function _Barcode_Create(text : PAnsiChar) : PBarcode_Item; cdecl;
function _Barcode_Delete(bc : PBarcode_Item) : integer; cdecl;


// Encode and print
function _Barcode_Encode(bc : PBarcode_Item; flags : integer) : integer; cdecl;
// function _Barcode_Print(bc : PBarcode_Item; f : PFILE; flags : integer) : integer;

// Choose the position
function _Barcode_Position(bc : PBarcode_Item; wid : integer; hei : integer; xoff : integer; yoff : integer; scalef : double) : integer; cdecl;


// Do it all in one step
//function _Barcode_Encode_and_Print(text : PAnsiChar; f : PFILE; wid : integer; hei : integer; xoff : integer; yoff : integer; flags : integer) : integer;


// Return current version (integer string : and)
function _Barcode_Version(versionname : PAnsiChar) : integer; cdecl;

function _Barcode_Output(bc : PBarcode_Item; Canvas : TBarcodeCanvas ) : integer;


function _malloc (Size: Cardinal): Pointer; cdecl;
procedure _memset (Src: Pointer; c: Integer; N: Cardinal); cdecl;
function _strdup( const s: PAnsiChar) : PAnsiChar; cdecl;
procedure _free (p: Pointer); cdecl;
function _strcpy( Dest: PChar; const source : PChar):PChar; cdecl;
function _strlen( const s: PAnsiChar) : Integer; cdecl;
function _isdigit (c: AnsiChar): Boolean; cdecl;
function __ltoupper (c: AnsiChar): AnsiChar; cdecl;
function _StrChr (const s: PAnsiChar; c: AnsiChar): PAnsiChar; cdecl;
procedure _memcpy (Dest: Pointer; Src: Pointer; N: Cardinal); cdecl;
function _islower (c: AnsiChar): Boolean; cdecl;
//function _sprintf( s: PAnsiChar;const fmt: PAnsiChar; const x : array of const): PChar; cdecl;
function _strcat( Dest : PChar; const Source: PChar) : PChar; cdecl;
function _atol( const Src: PChar) : longint; cdecl;
function _isalpha (c: AnsiChar): Boolean; cdecl;
function _isupper (c: AnsiChar): Boolean; cdecl;

var __streams : integer;
    __turboFloat: integer;
    _errno : integer;

implementation
uses sysutils, windows;
{$L library.obj}
{$L ean.obj}
{$L code128.obj}
{$L code39.obj}
{$L i25.obj}

// class TBarcode 
constructor TBarcode.Create(const txt : string);
begin
    FBC := _Barcode_Create(PChar(txt));
    if Assigned(FBC) then
        FBC^.margin := 0;
end;
destructor TBarcode.Destory;
begin
    if Assigned(FBC) then _Barcode_Delete(FBC);
    FBC:=nil;
end;
procedure TBarcode.SetText( const txt : string);
begin
    if Assigned(FBC) then _Barcode_Delete(FBC);
    FBC:=_Barcode_Create(PChar(txt));
end;

function TBarcode.Encode(CodeType :TBarCodeType; flags: Integer): integer;
begin
    result := _Barcode_Encode( FBC, (Ord(CodeType)- Ord(bcAny)) or flags);
    FBC.Flags := flags;
end;
function TBarcode.Encode(CodeTypes :TBarCodeTypes; flags: Integer): integer;
var
    bct: TBarCodeType;
    withChecksum : boolean;
    ch : AnsiChar;
    len : integer;
    txt : string;
begin
    withChecksum := bcWithChecksum in CodeTypes;
    if bcAny in CodeTypes then
        result := Encode(bcAny, flags)
    else
    begin
        if withChecksum then
        begin
            // try this one
            len := StrLen( FBC.ascii );
            if len > 1 then
            begin
                ch := FBC.ascii[len-1];
                FBC.ascii[len-1] := #0;
                for bct:= bcEAN to bcISBN do
                begin
                    if bct in CodeTypes then
                    begin
                        result := Encode(bct, flags);
                        if (Result <> -1) and ( FBC.checksum = Ord(ch)-Ord('0')) then
                            exit; // we have a winner
                    end;
                end;
                FBC.ascii[len-1] := ch; // Replace it
            end;
        end;
        // Might need to exclude bcEAN to bcISBN for 'withChecksum' or make it a last resort.
        for bct:= bcEAN to bcI25 do
        begin
            if bct in CodeTypes then
            begin
                // try this one
                result := Encode(bct, flags);
                if Result <> -1 then
                    exit; // We have a winner
            end;
        end;
        // Clear anything that happend
        txt := FBC.ascii;
        SetText(txt);
        result := -1;
    end;
end;

function TBarcode.Position(Width, Height, XOffset , YOffset : integer; ScaleFactor : double) : integer;
begin
    result := _Barcode_Position(FBC, Width,Height, XOffset, YOffset, ScaleFactor);
end;

function TBarcode.Draw( Canvas : TBarcodeCanvas ) : integer;
begin
    Result := _Barcode_Output(FBC, Canvas);
end;

function TBarcode.Version : string;
var
    ver: Integer;
begin
    ver := _Barcode_Version(nil);
    Result := Format('%.2f',[ver/100]);
end;

function TBarcode.IntVersion: integer;
begin
    Result := _Barcode_Version(nil);
end;




function isdigit(ch : AnsiChar) : Boolean;
begin
    Result := ch in ['0'..'9'];
end;
function islower(ch : AnsiChar) : Boolean;
begin
    Result := ch in ['a'..'z'];
end;
function isupper(ch : AnsiChar) : boolean;
begin
    Result := ch in ['A'..'Z'];
end;

function DigitOrdinal( ch : AnsiChar) : integer;
begin
    Result := Ord(ch)-Ord('0');
end;
function AlphaOrdinal( ch : AnsiChar) : integer ;
begin
    if isupper(ch) then
        Result := Ord(ch)-Ord('A')
    else if islower(ch) then
        Result := Ord(ch)-Ord('a')
    else
       Raise Exception.Create('Not an alpha');
end;

function iff( istrue : boolean; val1,val2 : Integer): integer;
begin
    if istrue then result := val1
    else result := val2;
end;

function Parse_CharPos( start : PChar; var f1, f2: double; var ch: AnsiChar): integer;
var
    part : string;
    s,e: PChar;
    i: Integer;
    f: double;
begin
    s:= start;
    e:= s;
    i:=1;
    while true do
    begin
        case e^ of
            #0,' ' :
            begin
                ch := (e-1)^;
                inc(i);
                break;
            end;
            ':':
            begin
                SetString(part, s, e-s);
                f:= StrToFloat(part);
                case i of
                    1 : f1 := f;
                    2 : f2 := f;
                end;
                s:= e+1;
                inc(i);
                if i = 3 then
                begin
                    ch := (s^);
                    inc(i);
                    break;
                end;
            end;
        end;
        inc(e);
    end;
    result := i-1;
end;

function _Barcode_Output(bc : PBarcode_Item; Canvas : TBarcodeCanvas ):integer;
var
    i, j, barlen, delta : Integer;
//    k, hei,wid : integer;
//    printable : Boolean;
    f1, f2, fsav, t1,t2 : double;
    mode : AnsiChar ; // text below bars
    scalef, xpos, x0, y0, yr : double ;
    ptr :PAnsiChar;
    c,ch : AnsiChar;
begin
    fsav := 0;
    scalef := 1;
    mode := '-';
    //printable := true;


    if not Assigned( bc.partial) or not Assigned(bc.textinfo) then
    Begin
        bc.error := -1;
        result :=  -1;
        exit;
    End;


    {*
     * Maybe this first part can be made common to several printing back-ends,
     * we'll see how that works when other ouput engines are added
     *}

    // First, calculate barlen 
    barlen := DigitOrdinal(bc.partial[0]);

    ptr := bc.partial+1;
    while ( ptr^ <> #0 ) do
    begin
        ch := ptr^;
        if isdigit( ch )  then
            inc(barlen, (DigitOrdinal(ch)))
        else if islower(ch) then // ch in ['a'..'z','A'..'Z'] //
        { Should this check for lower and upper ???????? }
            inc(barlen ,( AlphaOrdinal(ch) +1));
        Inc(ptr);
    end;

    (* The scale factor depends on bar length *)
    if (0 = bc.scalef) then
    Begin
        if (0 = bc.width) then bc.width := barlen; (* default *)

        t1:= bc.width;
        t2:= barlen;
        bc.scalef := t1 / t2;
        scalef := bc.scalef;
    End;

    (* The width defaults to "just enough" *)
    if (0 = bc.width) then  bc.width := Trunc(barlen * scalef +1);

    // But it can be too small, in this case enlarge and center the area
    (*
    if (bc.width < barlen * scalef) then
    Begin
        wid := Trunc(barlen * scalef )+ 1;
        dec(bc.xoff, (wid - bc.width)div 2) ;
        bc.width := wid;
        // Can't extend too far on the left
        if (bc.xoff < 0) then
        Begin
            dec(bc.width,bc.xoff);
            bc.xoff := 0;
        End;
    End;
    *)
    // The height defaults to 80 points (rescaled)
    if (0 = bc.height) then bc.height := Trunc(80 * scalef);

    // If too small (20 + text), enlarge and center
    (*
    i := 20;
    if ((bc.flags and bcNoAscii)=0) then
        inc (i, 20);
    if (bc.height < i * scalef ) then
    Begin
        hei := Trunc(i * scalef);
        dec(bc.yoff, hei div 2);
        bc.height := hei;
        if (bc.yoff < 0) then
        Begin
            inc(bc.height, -bc.yoff);
            bc.yoff := 0;
        End;
    End;
    *)
    (*
     * Ok, then deal with actual ps (eps) output
     *)

    {
    if (0 = (bc.flags & BARCODE_OUT_NOHEADERS)) then
    Begin (* spit a header first *)
        if (bc.flags & BARCODE_OUT_EPS)  then
            fprintf(f, "%%!PS-Adobe-2.0 EPSF-1.2\n")
        else
            fprintf(f, "%%!PS-Adobe-2.0\n");
        fprintf(f, "%%%%Creator: libbarcode\n");
        if (bc.flags & BARCODE_OUT_EPS) then
        Begin
            fprintf(f, "%%%%BoundingBox: %i %i %i %i\n",
                    bc.xoff,
                    bc.yoff,
                    bc.xoff + bc.width + 2* bc.margin,
                    bc.yoff + bc.height + 2* bc.margin);
        End;
        fprintf(f, "%%%%EndComments\n");
        if (bc.flags & BARCODE_OUT_PS) then
        Begin
            fprintf(f, "%%%%EndProlog\n\n");
            fprintf(f, "%%%%Page: 1 1\n\n");
        End;
    End;
    }

    (* Print some informative comments *)
    {
    for (i=0; bc.ascii[i]; i++)
        if (bc.ascii[i] < ' ') then
            printable := 0;

    fprintf(f,"%% Printing barcode for \"%s\", scaled %5.2f",
            printable ? bc.ascii : "<unprintable string>", scalef);
    if (bc.encoding) then
        fprintf(f,", encoded using \"%s\"",bc.encoding);
    fprintf(f, "\n");
    fprintf(f,"%% The space/bar succession is represented "
            "by the following widths (space first):\n"
            "%% ");
    for (i=0; i<strlen(bc.partial); i++)
    Begin
        unsigned char c := bc.partial[i];
        if (isdigit(c)) then putc(c, f);
        if (islower(c)) then putc(c-'a'+'1', f);
        if (isupper(c)) putc(c-'A'+'1', f);
    End;
    putc('\n', f);
    }

    xpos := bc.margin + (DigitOrdinal(bc.partial[0])) * scalef;

    //for (ptr = bc.partial+1, i=1; *ptr; ptr++, i++)
    ptr := bc.partial+1;
    i:=1;
    while ptr^ <> #0 do
    Begin
        (* special cases: '+' and '-' *)
        ch := ptr^;
        if ( ch = '+' ) or ( ch = '-') then
        Begin
            mode := ch;
            (* don't count it *) inc(i);
            inc(ptr);
            continue;
        End;
        (* j is the width of this bar/space *)
        if (isdigit (ch)) then
                j := DigitOrdinal(ch)
        else
                j := AlphaOrdinal(ch)+1;
        if (i mod 2) <> 0 then
        Begin (* bar *)
            x0 := bc.xoff + xpos + (j*scalef)/2;
            y0 := bc.yoff + bc.margin;
            yr := bc.height;
            if 0 = (bc.flags and bcNoAscii) then
            Begin (* leave space for text *)
                if (mode = '-') then
                Begin
                    (* text below bars: 10 points or five points *)
                    delta := Trunc(iff(isdigit(ch) , 10 , 5) * scalef);
                    y0 := y0 + delta;
                    yr := yr - delta;
                End
                else (* '+' *)
                Begin
                    (* text above bars: 10 or 0 from bottom, and 10 from top *)
                    y0 := y0 + Trunc(iff( isdigit(ch),10, 0) * scalef);
                    yr := yr - Trunc(iff( isdigit(ch),20,10) * scalef);
                End;
            End;

            Canvas.SetPenWidth(j*scalef-SHRINK_AMOUNT);
            Canvas.DrawLine( x0, y0, x0+0, y0+yr); 
            {
            fprintf(f,"%5.2f setlinewidth " "%6.2f %6.2f moveto " "0 %5.2f rlineto stroke\n",
                    (j * scalef) - SHRINK_AMOUNT, x0, y0, yr);
            }
        End;
        xpos := xpos + (j * scalef);
        inc(ptr);
        inc(i);
    End;
    {fprintf(f,"\n");}

    (* Then, the text *)

    mode := '-'; (* reinstantiate default *)
    if 0 = (bc.flags and bcNoAscii)  then
    Begin
       // k:=0; // k is the "previous font size" 
        { for (ptr = bc.textinfo; ptr; ptr = strchr(ptr, ' ')) }
        ptr := bc.textinfo;
        while true do
        Begin
            if not Assigned(ptr) then break;

            while (ptr^ = ' ') do Inc(ptr);

            ch := ptr^;

            if ch = #0 then break;

            if ch in ['+','-'] then
            Begin
                mode := ch;
                continue;
            End;


    {        if (sscanf(ptr, "%lf:%lf:%c", &f1, &f2, &c) <> 3) then}
            if Parse_CharPos( ptr, f1,f2,c) <> 3 then
            Begin
                // fprintf(stderr, 'barcode: impossible data: %s\n', ptr);
                continue;
            End;
            if (fsav<>f2) then
            Begin (* Don't repeat "findfont" if unneeded *)
                { fprintf(f, "/Helvetica findfont %5.2f scalefont setfont\n", f2 * scalef);}
                // Canvas.FontName := 'Helvetica';
                Canvas.SetFontSize(f2*scalef); // << This could be wrong!
            End;
            fsav := f2; (* for next time *)

            {
            fprintf(f, "%5.2f %5.2f moveto (", bc.xoff + f1 * scalef + bc.margin, mode = '-'
                       ? (double)bc.yoff + bc.margin
                       : (double)bc.yoff + bc.margin+bc.height - 8*scalef);
           }

            (* Both the backslash and the close parens are special *)
            {
            if (c='\' ) or ( c=')') then fprintf(f, "\\%c) show\n", c)
            else fprintf(f, "%c) show\n", c);
            }
           if mode = '-' then
               Canvas.TextOut( bc.xoff + f1 * scalef + bc.margin,bc.yoff + bc.margin, c )
           else
               Canvas.TextOut( bc.xoff + f1 * scalef + bc.margin,bc.yoff + bc.margin +
                   bc.height -8*scalef , c);

            ptr := AnsiStrScan( ptr, ' ');
        End;
    End;

    {
    fprintf(f,"\n%% End barcode for \"%s\"\n\n", printable ? bc.ascii : "<unprintable string>");

    if (0 = (bc.flags & BARCODE_OUT_NOHEADERS)) then
    Begin
        fprintf(f,"showpage\n");
        if (bc.flags & BARCODE_OUT_PS) then
        Begin
            fprintf(f, "%%%%Trailer\n\n");
        End;
    End;
    }
    Result := 0;
End;

// External Declarations
function _Barcode_Create; external;
function _Barcode_Delete; external;
// Encode and print
function _Barcode_Encode; external;
// function _Barcode_Print; external;
// Choose the position
function _Barcode_Position; external;
// Do it all in one step
//function _Barcode_Encode_and_Print; external;
// Return current version
function _Barcode_Version; external;

procedure _Barcode_ps_print; cdecl;
begin
end;
{
function __ftol( x: double) : longint; cdecl;
begin
    result := trunc(x);
end;
 }
function _format_coordinates( dest : PAnsiChar ; x,y : integer; ch : Char ): integer; cdecl;
begin
    if Ord(ch) < 27 then ch := Char(Ord('0')+ord(ch));
    StrFmt(dest,' %d:%d:%s', [x,y,ch]);
    result := 0;
end;
function _format_float_coordinates( dest : PAnsiChar; x,y : Double; ch :Char) : integer; cdecl;
begin
    if Ord(ch) < 27 then ch := Char(Ord('0')+ord(ch)); 
    StrFmt(dest, ' %g:%g:%s', [x,y,ch]);
    result :=0;
end;


function _malloc (Size: Cardinal): Pointer; cdecl;
begin
 GetMem (Result, Size);
end;
procedure _memset (Src: Pointer; c: Integer; N: Cardinal); cdecl;
begin
 FillChar (Src^, N, c);
end;
function _strdup( const s: PAnsiChar) : PAnsiChar; cdecl;
begin
    GetMem(Result, StrLen(s)+1);
    StrCopy( Result, s );
end;
procedure _free (p: Pointer); cdecl;
begin
 FreeMem (p);
end;
function _strcpy( Dest: PChar; const source : PChar):PChar; cdecl;
begin
    StrCopy(Dest,source);
    result := Dest;
end;
function _strlen( const s: PAnsiChar) : Integer; cdecl;
begin
    result := StrLen(s);
end;
function _isdigit (c: AnsiChar): Boolean; cdecl;
var
 CharType           : Word;
begin
 GetStringTypeExA (LOCALE_USER_DEFAULT, CT_CTYPE1, @c, SizeOf (c), CharType);
 Result := Boolean (CharType and C1_DIGIT);
end;
function __ltoupper (c: AnsiChar): AnsiChar; cdecl;
begin
 CharUpper (@c);
 Result := c;
end;
function _StrChr (const s: PAnsiChar; c: AnsiChar): PAnsiChar; cdecl;
begin
 Result := StrScan (s, c);
end;
procedure _memcpy (Dest: Pointer; Src: Pointer; N: Cardinal); cdecl;
begin
 Move (Src^, Dest^, N);
end;
function _islower (c: AnsiChar): Boolean; cdecl;
begin
    Result := IsCharLower (c);
end;
function _strcat( Dest : PChar; const Source: PChar) : PChar; cdecl;
begin
    result := StrCat(Dest,Source);
end;
function _atol( const Src: PChar) : longint; cdecl;
begin
    result := StrToInt(src);
end;
function _isalpha (c: AnsiChar): Boolean; cdecl;
begin
 Result := IsCharAlpha (c);
end;
function _isupper (c: AnsiChar): Boolean; cdecl;
begin
 Result := IsCharUpper (c);
end;

procedure _debug_print( const s: PChar) ; cdecl;
begin

end;
procedure _debug_print_float( d: Double) ; cdecl;
begin

end;

procedure _debug_print_int( l:longint) ; cdecl;
begin

end;

function _trunc( d :Double): longint; cdecl;
begin
    Result := trunc(d);
end;

End.




