package provide Freetype::init 0.1

if {![info exists _source([file tail [info script]])]} {
package require TclOO
package require Ffidl
package require Ffidlrt

#
# Initial parameter
#
namespace eval ft {
    set paths [list \
        "/usr/lib/libfreetype.so.6" \
        "/usr/local/lib/libfreetype.so.6" \
        "C:/Program Files/GIMP 2/bin/libfreetype-6.dll" \
    ]
    if {$tcl_platform(pointerSize) == 4} {
        lappend paths "/usr/lib/i386-linux-gnu/libfreetype.so.6"
        lappend paths "C:/msys2/mingw32/bin/libfreetype-6.dll"
    } else {
        lappend paths "/usr/lib/x86_64-linux-gnu/libfreetype.so.6"
        lappend paths "C:/msys2/mingw64/bin/libfreetype-6.dll"
    }
    set lib ""
    set target_version 2.5.2

    proc init {} {
        variable lib
        variable paths

        foreach path $paths {
            if {[file exists $path]} {
                set lib $path
                append ::env(PATH) ";[file dir $path];"
                break
            }
        }
    }

    init

    proc _bytearray_from_pointer {i} {
        return [binary format [::ft::_ffidl_format pointer] $i]
    }
    proc _bytearray_to_pointer {p} {
        binary scan $p [::ft::_ffidl_format pointer] v
        return $v
    }
    proc _bytearray_from_int32 {i} {
        return [binary format i $i]
    }
    proc _bytearray_to_int32 {p} {
        binary scan $p i v
        return $v
    }
    proc _bytearray_from_unit32 {i} {
        return [binary format iu $i]
    }
    proc _bytearray_to_uint32 {p} {
        binary scan $p iu v
        return $v
    }
    proc _bytearray_from {ffidltype value} {
        return [binary format [::ft::_ffidl_format $ffidltype] {*}$value]
    }
    proc _bytearray_to {ffidltype value} {
        binary scan $value [::ft::_ffidl_format $ffidltype] v
        return $v
    }

    proc _f26dot6_from_double {var} {
        return [expr {int($var * 64.0)}]
    }
    proc _f26dot6_to_double {var} {
        return [expr {double($var / 64.0)}]
    }
    proc _f16dot16_from_double {var} {
        return [expr {int($var * 65536.0)}]
    }
    proc _f16dot16_to_double {var} {
        return [expr {double($var / 65536.0)}]
    }
    proc _f2dot16_from_double {var} {
        return [expr {int($var * 65536.0)}]
    }
    proc _f2dot16_to_double {var} {
        return [expr {double($var / 65536.0)}]
    }
    proc _fixed_from_double {var} {
        return [_f16dot16_from_double $var]
    }
    proc _fixed_to_double {var} {
        return [_f16dot16_to_double $var]
    }
    proc _tag_from_integer {value} {
        binary scan [binary format I $value] a* v
        return $v
    }

    proc __new_buf {len} {
        return [binary format x$len]
    }

    #if size=-1 then array of address is terminated 0
    proc _bytearray_from_address {address ffidltype size} {
        set elemsize [ffidl::info sizeof $ffidltype]

        if {$size >= 0} {
            return [::ffidl::peek $address [expr {$elemsize * $size}]]
        }
        # parse null terminated array
        set result [binary format x0]
        while {1} {
            set bin [::ffidl::peek $address $elemsize]
            binary scan $bin [::ft::_ffidl_format $ffidltype] value
            if {$value == 0} {break}

            append result $bin
            incr address $elemsize
        }
        return $result
    }

    proc _bytearray_to_list {bin ffidltype} {
        set fmt [::ft::_ffidl_format $ffidltype]
        set elemsize [ffidl::info sizeof $ffidltype]
        if {[string length $bin] <= 0} return [list]
        
        binary scan $bin $fmt* value
        return $value
    }

    proc _bytearray_from_list {list ffidltype} {
        set elemsize [::ffidl::info sizeof $ffidltype]
        set fmt [::ft::_ffidl_format $ffidltype]
        set bin [binary format x0]
        foreach i $list {
            append bin [binary format $fmt $i]
        }
        return $bin
    }

    proc _ffidl_format {ffidltype} {
        switch -exact -- $ffidltype {
            "uint8"              -
            "FT_Bool"            -
            "FT_Byte"            -
            "unsigned char"      {return "cu"}
            "uint16"             -
            "FT_UFWord"          -
            "FT_UShort"          -
            "FT_UInt16"          -
            "unsigned short"     {return "su"}
            "uint32"             -
            "FT_UInt"            -
            "FT_UInt32"          -
            "FT_Tag"             -
            "FT_ULong"           -
            "unsigned"           -
            "unsigned long"      -
            "unsigned int"       {return "iu"}
            "uint64"             -
            "unsigned long long" {return "wu"}

        }
        return [::ffidl::info format $ffidltype]
    }

    ::ffidl::callout get_callback_address {pointer-proc} pointer \
        [::ffidl::symbol [::ffidl::find-lib ffidl] ffidl_pointer_pun]

    # memcpy is not use pointer-var such like ffidl::memcpy
    ::ffidl::callout memcpy {pointer pointer int} pointer \
        [::ffidl::symbol [::ffidl::find-lib c] memcpy]
}



proc ::ft::get_bytearray_pointer {objName addressName lenName} {
    upvar $objName      _obj
    upvar $lenName      _len
    upvar $addressName  _adr
    
    set len [binary format [::ft::_ffidl_format int] 0]
    set adr [::ffidl::get-bytearray-from-obj $_obj len]
    binary scan $len [::ft::_ffidl_format int] _len
    set _adr $adr
    return
}
#get address of pointer
proc ::ft::get_pointer_pointer {address} {
    if {$address == 0} {return 0}
    set bin [::ffidl::peek $address [::ffidl::info sizeof "pointer"]]
    return [::ft::_bytearray_to_pointer $bin]
}

#
# base class object
#
oo::class create ::ft::struct {
    constructor {{pointer ""}} {
        variable _pointer    0
        variable _bin        {}
        variable _allocated [list]
        variable _members    
        variable _ffidl_type 
        variable _member_info_types [list name tcltype ptr ffidltype array_count offsettype]

        if {$pointer == {}} {
            set size 0
            foreach array_count [my _get_member_info array_count] type [my _get_member_info offsettype] {
                incr size [expr {[::ffidl::info sizeof $type] * $array_count}]
            }
            set p [::ffidl::malloc $size]
            lappend _allocated $p
            set bin [binary format x$size]
            ::ft::get_bytearray_pointer bin adr len
            ft::memcpy $p $adr $len
            set _pointer $p
        } else {
            set _pointer $pointer
        }
    }

    destructor {
        variable _allocated

        foreach adr [lreverse $_allocated] {
            ::ffidl::free $adr
        }
    }

    method _format_list_as_or {namelist} {
        if {[llength $namelist] == 0} {return ""}
        if {[llength $namelist] == 1} {return $namelist}
        if {[llength $namelist] >= 2} {
            set keyslist1 [lrange $namelist 0 end-1]
            set keyslist2 [lindex $namelist end]
            return "[join $keyslist1 {, }] or [lindex $keyslist2 0]"
        }
    }

    method _get_member_info {membertype} {
        variable _members
        variable _member_info_types
        set vallist [list]
        foreach member $_members {
            lassign $member {*}$_member_info_types
            lappend vallist [set $membertype]
        }
        return $vallist
    }

    method _check_member_exists {varName} {
        set names [list]
        foreach name [my _get_member_info name] {
            lappend names $name
        }

        if {$varName ni $names} {
            error "unknown member, must be [my _format_list_as_or $names]"
        }
    }

    method _check_member_info_exists {infoName} {
        variable _member_info_types
        if {$infoName ni $_member_info_types} {
            error "unknown member, must be [my _format_list_as_or $_member_info_types]"
        }
    }

    method _get_tcl_list_value {num ptr tcltype ffidltype} {
        set ret [list]
        if {$ptr > 0 && $num > 0} {
            set size [::ffidl::info sizeof $ffidltype]
            for {set i 0} {$i < $num} {incr i} {
                lappend ret [my _get_tcl_value_from_ptr $ptr $tcltype $ffidltype]
                incr ptr $size
            }
        }
        return $ret
    }

    #set tcl object to address and type
    method _set_tcl_value_to_ptr {address tcltype ptr ffidltype value} {
        if {$address == 0 || $address eq ""} {
            error "null pointer reference"
        }

        if {$tcltype eq "string"} {
            set src {}
            set len 0
            set bin [encoding convertto [encoding system] $value] ;# string must be bytearray
            append bin \x00
            ::ft::get_bytearray_pointer bin adr len
            set mem [::ffidl::malloc $len]
            ft::memcpy $mem $adr $len
            lappend _allocated $mem

            # write pointer address
            set bin [binary format [::ft::_ffidl_format "pointer"] $mem]
            ::ft::get_bytearray_pointer bin adr len
            ::ft::memcpy $address $adr $len
            return
        }

        if {$tcltype eq "object"} {
            set obj $value
            if {[info object isa typeof $obj $ffidltype] == 0} {
                error "\"$obj\" is not a type of $ffidltype"
            }
            if {$ptr == "*"} {
                set bin [::ft::_bytearray_from_pointer [$obj getPointer]]
                ::ft::get_bytearray_pointer bin adr len
                ft::memcpy $address $adr $len
            } else {
                set adr  [$obj getPointer]
                set len  [::ffidl::info sizeof $ffidltype]
                set size [::ffidl::info sizeof $ffidltype]
                ft::memcpy $address $adr $len
            }
            return
        }

        set bin [binary format [::ft::_ffidl_format $ffidltype] $value]
        ::ft::get_bytearray_pointer bin src len
        ft::memcpy $address $src $len
        return
    }

    #get tcl object from address and type
    method _get_tcl_value_from_ptr {address tcltype ffidltype} {
        if {$address == 0 || $address eq ""} {
            if {$tcltype eq "object"} {
                return {}
            } else {
                error "null pointer reference"
            }
        }

        # char pointer or null
        if {$tcltype eq "string"} {
            set address [::ft::get_pointer_pointer $address]
            set bin [::ffidl::new-string $address -1]
            return [encoding convertfrom [encoding system] $bin]
        }

        # struct (pointer)
        if {$tcltype eq "object"} {
            set instances [::info class instances $ffidltype]
            set obj {}
            foreach instance $instances {
                if {[::info object isa typeof $instance ft::struct] && [$instance getPointer] == $address} {
                    set obj $instance
                    break
                }
            }
            if {$obj == {}} {
                return [$ffidltype new $address]
            } else {
                return $obj
            }
        }

        # number, pointer
        set bin [::ffidl::peek $address [::ffidl::info sizeof $ffidltype]]
        binary scan $bin [::ft::_ffidl_format $ffidltype] value
        return $value
    }

    method _get_tcl_list_from_array_pointer {varName numVarName} {
        set num [my get $numVarName]
        set size      [my getSize $varName]
        set tcltype   [my getInfo $varName tcltype]
        set ffidltype [my getInfo $varName ffidltype]
        set adr       [::ft::get_pointer_pointer [my getPointer $varName]]
        if {$num == 0 || $adr == 0} {return {}}
        if {$tcltype eq "object"} {
            set ret [list]
            for {set i 0} {$i < $num} {incr i} {
                lappend ret [$ffidltype new [expr {$adr + ($i * $size)}]]
            }
            return $ret
        } else {
            set bin [ffidl::peek $adr [expr {$num * $size}]]
            return [::ft::_bytearray_to_list $bin $ffidltype]
        }
    }

    #
    # Setter
    #
    method set {varName varValue} {
        variable _members
        variable _pointer
        variable _allocated
        variable _member_info_types

        my _check_member_exists $varName

        if {$_pointer == 0 || $_pointer eq ""} {
            error "null pointer reference"
        }

        foreach member $_members {
            lassign $member {*}$_member_info_types
            if {$name eq $varName} {
                set p [my getPointer $name]

                for {set i 0} {$i < $array_count} {incr i} {
                    if {$array_count == 1} {
                        set val $varValue
                    } else {
                        set val [lindex $varValue $i]
                    }

                    my _set_tcl_value_to_ptr $p $tcltype $ptr $ffidltype $val

                    if {$ptr eq "*"} {
                        incr p [ffidl::info sizeof "pointer"]
                    } else {
                        incr p [ffidl::info sizeof $ffidltype]
                    }
                }
                return [my get $varName]
            }
        }
    }
    export set

    #
    # Getter
    #
    method get {varName} {
        variable _members
        variable _pointer
        variable _member_info_types

        my _check_member_exists $varName

        if {$_pointer == 0 || $_pointer eq ""} {
            error "null pointer reference"
        }
        
        foreach member $_members {
            lassign $member {*}$_member_info_types

            if {$name eq $varName} {
                set adr [my getPointer $name]

                if {$array_count == 1} {
                    if {$ptr == "*" && $tcltype == "object"} {
                        set adr [my _get_tcl_value_from_ptr $adr "int" "pointer"]
                    }
                    set val [my _get_tcl_value_from_ptr $adr $tcltype $ffidltype]
                    return $val
                } else {
                    if {$ptr == "*"} {
                        set size [::ffidl::info sizeof "pointer"]
                    } else {
                        set size [::ffidl::info sizeof $ffidltype]
                    }
                    set vallist [list]
                    for {set i 0} {$i < $array_count} {incr i} {
                        lappend vallist [my _get_tcl_value_from_ptr $adr $tcltype $ffidltype]
                        incr adr $size
                    }
                    return $vallist
                }
            }
        }
    }
    export get

    #
    # Get Member names
    #
    method getMembers {} {
        return [my _get_member_info name]
    }
    export getMembers

    #
    # Return true if type of a member is pointer
    #
    method isPointer {varName} {
        variable _members
        variable _pointer
        variable _allocated
        variable _member_info_types

        my _check_member_exists $varName

        if {$_pointer == 0 || $_pointer eq ""} {
            error "null pointer reference"
        }

        foreach member $_members {
            lassign $member {*}$_member_info_types
            if {$name eq $varName} {
                if {$ptr eq "*"} {
                    return 1
                } else {
                    return 0
                }
            }
        }
        return 0
    }
    export isPointer

    method _get_union_ffidltypes {firstVarName} {
        variable _members
        variable _pointer
        variable _allocated
        variable _member_info_types

        set types [list]
        foreach member $_members {
            lassign $member {*}$_member_info_types
            if {$firstVarName eq $name} {
                lappend types $ffidltype
            } else {
                if {[llength $types] > 0} {
                    lappend types $ffidltype
                    if {$offsettype ne "void"} {
                        return $types
                    }
                }
            }
        }
        return
    }

    #
    # Get pointer of this object if member is not null, or get pointer of
    # a member.
    #
    method getPointer {{varName ""}} {
        variable _members
        variable _pointer
        variable _allocated
        variable _member_info_types

        if {$varName eq ""} {
            return $_pointer
        }

        my _check_member_exists $varName

        if {$_pointer == 0 || $_pointer eq ""} {
            error "null pointer reference"
        }

        set pos 0
        foreach member $_members {
            set is_in_union 0
            lassign $member {*}$_member_info_types
            # align union type
            if {$offsettype eq "void" && $is_in_union == 0} {
                set union_types [my _get_union_ffidltypes $name]
                set max 0
                foreach union_type $union_types {
                    set alignment [ffidl::info alignof $union_type]
                    if {$max < $alignment} {
                        set max $alignment
                    }
                }
                set alignment $max
                set is_in_union 1
            } else {
                set alignment [ffidl::info alignof $offsettype]
                set is_in_union 0
            }

            if {$alignment > 0 && ($pos % $alignment) != 0} {
                incr pos [expr {$alignment - ($pos % $alignment)}]
            }

            if {$name eq $varName} {
                return [expr {$_pointer + $pos}]
            }
            set size [expr {[::ffidl::info sizeof $offsettype] * $array_count}]
            incr pos $size
        }
        return 0
    }
    export getPointer


    #
    #
    #
    method isNull {} {
        if {[my getPointer] == 0} {
            return 1
        } else {
            return 0
        }
    }
    export isNull

    method toDict {} {
        set d [dict create]
        foreach name [my _get_member_info name] {
            dict set d $name [my get $name]
        }
        return $d
    }
    export toDict

    method getClass {} {
        return [string trimleft [info object class [self object]] ::]
    }
    export getClass

    method getSize {{varName ""}} {
        if {$varName eq ""} {
            set myclass [my getClass]
            return [::ffidl::info sizeof $myclass]
        }
        my _check_member_exists $varName

        set ffidltype [my getInfo $varName ffidltype]
        set is_ptr    [my getInfo $varName ptr]
        if {$ffidltype ne ""} {
            return [ffidl::info sizeof $ffidltype]
        }
        return 0
    }
    export getSize

    method getInfo {varName infoType} {
        my _check_member_exists $varName
        my _check_member_info_exists $infoType

        foreach name [my _get_member_info name] value [my _get_member_info $infoType] {
            if {$name eq $varName} {
                return $value
            }
        }
        return
    }
    export getInfo

}


oo::objdefine ::ft::struct method define {typename members} {
    set types [list]
    foreach member $members {
        lassign $member name tcltype ptr ffidltype array_count offsettype
        if {$offsettype eq "void" || $offsettype eq ""} {continue}
        if {$ptr eq "*"} {set offsettype "pointer"}
        for {set i 0} {$i < $array_count} {incr i} {
            lappend types $offsettype
        }
    }
    set name ""
    if {[llength $types] > 0} {
        ::ffidl::typedef $typename {*}$types
        set name $typename
    } else {
        ::ffidl::typedef $typename void ;# unknown size
    }

    oo::class create ::$typename [subst {
        superclass ft::struct
        
        constructor {{pointer ""}} {
            variable _ffidl_type $name
            variable _members    [list $members]
            next \$pointer
        }
    }]
}


# name   tcltype ptr objtype  array_count  sizetype
#{name   string  *   pointer   1            pointer}
#{width  int     -   int       1            int    };number
#{ints   int     -   int      10            int    };array of number
#{size   object  -   size      1            size   };struct in struct
#{sizes  object  *   size     10            pointer};pointer of struct array
#{pos    object  -   size      1            size   };struct in struct
#{ppos   object  *   size      1            pointer};pointer of struct
#                                           
#{ppos   object   size        10            size   };array of struct
#
#
#{num int  -  int   1   int    }; int num;
#{num int  *  int   1   pointer}; int *num;
#{num int  -  int  10   pointer}; int num[10];
#{num int  *  int  10   pointer}; int *num[10];


set _source([file tail [info script]]) 1
}
