# Copyright: 2021-2026 Paul Obermeier (obermeier@poSoft.de)
# Distributed under BSD license.
#
# Module for reading and writing of FLIR image files with pure Tcl.
# Currently the FLIR Public Image Format (FPF) is supported.

namespace eval pawt {
    namespace eval flir {
        variable ns [namespace current]

        namespace export ReadImageFile
        namespace export ReadImageHeader

        #
        # Utility procedures.
        #

        proc _GetImageTypeName { imgType } {
            switch -exact $imgType {
                0 { return "Temperature" }
                1 { return "TemperatureDifference" }
                2 { return "ObjectSignal" }
                3 { return "ObjectSignalDifference" }
            }
            return "UnknownImageType"
        }

        proc _GetPixelTypeName { pixelType } {
            switch -exact $pixelType {
                0 { return "short" }
                1 { return "int" }
                2 { return "float" }
                3 { return "double" }
            }
            return "UnknownPixelType"
        }

        proc _GetPixelType { pixelTypeName } {
            switch -exact $pixelTypeName {
                "short"  { return 0 }
                "int"    { return 1 }
                "float"  { return 2 }
                "double" { return 3 }
            }
            error "Invalid PixelType value: $pixelType (must be 0, 1, 2 or 3)"
        }

        proc _GetPixelSize { pixelType } {
            switch -exact $pixelType {
                0 { return 2 }
                1 { return 4 }
                2 { return 4 }
                3 { return 8 }
            }
            error "Invalid PixelType value: $pixelType (must be 0, 1, 2 or 3)"
        }

        proc _GetScanFormat { pixelType byteOrder } {
            if { $byteOrder eq "Intel" } {
                switch -exact $pixelType {
                    0 { return "su" }
                    1 { return "iu" }
                    2 { return "r" }
                    3 { return "q" }
                }
            } else {
                switch -exact $pixelType {
                    0 { return "Su" }
                    1 { return "Iu" }
                    2 { return "R" }
                    3 { return "Q" }
                }
            }
            error "Invalid PixelType value: $pixelType (must be 0, 1, 2 or 3)"
        }

        proc _ReadShort { fp } {
            set rawVal [read $fp 2]
            if { $rawVal ne "" } {
                if { 1 != [binary scan $rawVal su val] } {
                    set filePos [tell $fp]
                    close $fp
                    error "Could not read 2 bytes for short value at file position $filePos"
                }
                return $val
            } else {
                set filePos [tell $fp]
                close $fp
                error "Could not read short value at file position $filePos"
            }
        }

        proc _WriteShort { fp value } {
            puts -nonewline $fp [binary format s $value]
        }

        proc _ReadInt { fp } {
            set rawVal [read $fp 4]
            if { $rawVal ne "" } {
                if { 1 != [binary scan $rawVal iu val] } {
                    set filePos [tell $fp]
                    close $fp
                    error "Could not read 4 bytes for integer value at file position $filePos"
                }
                return $val
            } else {
                set filePos [tell $fp]
                close $fp
                error "Could not read integer value at file position $filePos"
            }
        }

        proc _WriteInt { fp value } {
            puts -nonewline $fp [binary format i $value]
        }

        proc _ReadFloat { fp } {
            set rawVal [read $fp 4]
            if { $rawVal ne "" } {
                if { 1 != [binary scan $rawVal f val] } {
                    set filePos [tell $fp]
                    close $fp
                    error "Could not read 4 bytes for float value at file position $filePos"
                }
                return $val
            } else {
                set filePos [tell $fp]
                close $fp
                error "Could not read float value at file position $filePos"
            }
        }

        proc _WriteFloat { fp value } {
            puts -nonewline $fp [binary format f $value]
        }

        proc _ReadString { fp size } {
            set rawVal [read $fp $size]
            if { $rawVal ne "" } {
                if { 1 != [binary scan $rawVal a$size val] } {
                    set filePos [tell $fp]
                    close $fp
                    error "Could not read $size bytes for string value at file position $filePos"
                }
                return $val
            } else {
                set filePos [tell $fp]
                close $fp
                error "Could not read string value at file position $filePos"
            }
        }

        proc _WriteString { fp value size } {
            puts -nonewline $fp [binary format a$size $value]
        }

        #
        # Image header read/write procedures.
        #

        proc _GetImageHeader { fp fileName } {
            set magic    "FPF Public Image Format"
            set magicLen [string length $magic]
            set fpfId    [_ReadString $fp 32]

            if { ! [string equal -length $magicLen $fpfId $magic] } {
                close $fp
                error "Invalid value for header field FPF_ID: Must be \"FPF Public Image Format\"."
            }
            set version            [_ReadInt $fp]
            set imageDataOffset    [_ReadInt $fp]
            set imageType          [_ReadShort $fp]
            set pixelType          [_ReadShort $fp]
            if { $pixelType < 0 || $pixelType > 3 } {
                close $fp
                error "Invalid value for header field PixelType: Must be 0, 1, 2 or 3."
            }
            set width              [_ReadShort $fp]
            set height             [_ReadShort $fp]
            if { $width < 1 } {
                close $fp
                error "Invalid value for header field Width: Must be greater than zero."
            }
            if { $height < 1 } {
                close $fp
                error "Invalid value for header field Height: Must be greater than zero."
            }
            set triggerCount       [_ReadInt $fp]
            set frameCount         [_ReadInt $fp]
            set spare1             [_ReadString $fp 64]
            set cameraName         [_ReadString $fp 32]
            set cameraPartNum      [_ReadString $fp 32]
            set cameraSerialNum    [_ReadString $fp 32]
            set cameraTempRangeMin [_ReadFloat $fp]
            set cameraTempRangeMax [_ReadFloat $fp]
            set lensName           [_ReadString $fp 32]
            set lensPartNum        [_ReadString $fp 32]
            set lensSerialNum      [_ReadString $fp 32]
            set filterName         [_ReadString $fp 32]
            set filterPartNum      [_ReadString $fp 32]
            set filterSerialNum    [_ReadString $fp 32]
            set spare2             [_ReadString $fp 64]
            set emissivity         [_ReadFloat $fp]
            set objectDistance     [_ReadFloat $fp]
            set apparentTemp       [_ReadFloat $fp]
            set atmosphereTemp     [_ReadFloat $fp]
            set relativeHumidity   [_ReadFloat $fp]
            set computedAtmTrans   [_ReadFloat $fp]
            set estimatedAtmTrans  [_ReadFloat $fp]
            set referenceTemp      [_ReadFloat $fp]
            set extOpticsTemp      [_ReadFloat $fp]
            set extOpticsTrans     [_ReadFloat $fp]
            set spare3             [_ReadString $fp 64]
            set year               [_ReadInt $fp]
            set month              [_ReadInt $fp]
            set day                [_ReadInt $fp]
            set hour               [_ReadInt $fp]
            set minute             [_ReadInt $fp]
            set second             [_ReadInt $fp]
            set millisecond        [_ReadInt $fp]
            set spare4             [_ReadString $fp 64]
            set cameraScaleMin     [_ReadFloat $fp]
            set cameraScaleMax     [_ReadFloat $fp]
            set calculatedScaleMin [_ReadFloat $fp]
            set calculatedScaleMax [_ReadFloat $fp]
            set actualScaleMin     [_ReadFloat $fp]
            set actualScaleMax     [_ReadFloat $fp]
            set spare5             [_ReadString $fp 192]

            set headerDict [dict create]
            set numChan 1

            # Store the values contained in the header.
            dict set headerDict Magic     "FLIR"
            dict set headerDict Width     $width
            dict set headerDict Height    $height
            dict set headerDict NumChan   $numChan
            dict set headerDict ByteOrder [::pawt::GetNativeByteOrder]
            dict set headerDict ScanOrder "TopDown"
            dict set headerDict PixelType [_GetPixelTypeName $pixelType]

            # Calculate derived information from the header values.
            set pixelSize [_GetPixelSize   $pixelType]
            set scanFmt   [_GetScanFormat  $pixelType "Intel"]
            dict set headerDict PixelSize  $pixelSize
            dict set headerDict ScanFormat $scanFmt
            dict set headerDict NumPixel   [expr { $width * $height }]
            dict set headerDict NumByte    [expr { $width * $height * $numChan * $pixelSize }]
            dict set headerDict FileName   $fileName
            return $headerDict
        }

        proc ReadImageHeader { flirImgFile args } {
            # Read the header of a FLIR image file.
            #
            # flirImgFile - File name of the FLIR image.
            # args        - Optional format specific arguments. Currently none.
            #
            # See [::pawt::ReadImageHeader] for the default entries of a
            # header dictionary.
            #
            # Returns the header information as a dictionary.
            # If the file does not exist or the header contains invalid information,
            # an error is thrown.
            #
            # See also: ReadImageFile WriteImageFile

            set retVal [catch {open $flirImgFile "r"} fp]
            if { $retVal != 0 } {
                error "Cannot open file $flirImgFile"
            }
            fconfigure $fp -translation binary
            set headerDict [_GetImageHeader $fp [file tail $flirImgFile]]
            close $fp
            return $headerDict
        }

        proc _GetAsInt { val } {
            set trimmed [string trimleft $val "0"]
            if { $trimmed eq "" } {
                set trimmed 0
            }
            return [expr { int ($trimmed) }]
        }

        proc _PutImageHeader { fp headerDict writeDate } {
            # Section Image Data
            set fpfId              "FPF Public Image Format"
            set version            2
            set imageDataOffset    892
            set imageType          0    ; # Temperature
            set pixelType          [_GetPixelType [dict get $headerDict PixelType]]
            set width              [dict get $headerDict Width]
            set height             [dict get $headerDict Height]
            set triggerCount       0
            set frameCount         1

            # Section Camera Data
            set cameraName         "Unknown"
            set cameraPartNum      "Unknown"
            set cameraSerialNum    "Unknown"
            set cameraTempRangeMin 0.0
            set cameraTempRangeMax 0.0
            set lensName           "Unknown"
            set lensPartNum        "Unknown"
            set lensSerialNum      "Unknown"
            set filterName         "Unknown"
            set filterPartNum      "Unknown"
            set filterSerialNum    "Unknown"

            # Section Object Parameter
            set emissivity         0.0
            set objectDistance     0.0
            set apparentTemp       0.0
            set atmosphereTemp     0.0
            set relativeHumidity   0.0
            set computedAtmTrans   0.0
            set estimatedAtmTrans  0.0
            set referenceTemp      0.0
            set extOpticsTemp      0.0
            set extOpticsTrans     0.0

            # Section DateAndTime
            if { $writeDate } {
                set curDate [clock format [clock milliseconds] -format "%Y %m %d %H %M %S"]
                lassign $curDate year month day hour minute second
            } else {
                set year   0
                set month  0
                set day    0
                set hour   0
                set minute 0
                set second 0
            }
            set millisecond 0

            # Section Scaling
            set cameraScaleMin     0.0
            set cameraScaleMax     0.0
            set calculatedScaleMin 0.0
            set calculatedScaleMax 0.0
            set actualScaleMin     0.0
            set actualScaleMax     0.0

            # Section Image Data
            _WriteString $fp $fpfId 32
            _WriteInt    $fp $version
            _WriteInt    $fp $imageDataOffset
            _WriteShort  $fp $imageType
            _WriteShort  $fp $pixelType
            _WriteShort  $fp $width
            _WriteShort  $fp $height
            _WriteInt    $fp $triggerCount
            _WriteInt    $fp $frameCount
            _WriteString $fp " " 64

            # Section Camera Data
            _WriteString $fp $cameraName 32
            _WriteString $fp $cameraPartNum 32
            _WriteString $fp $cameraSerialNum 32
            _WriteFloat  $fp $cameraTempRangeMin
            _WriteFloat  $fp $cameraTempRangeMax 
            _WriteString $fp $lensName 32
            _WriteString $fp $lensPartNum 32
            _WriteString $fp $lensSerialNum 32
            _WriteString $fp $filterName 32
            _WriteString $fp $filterPartNum 32
            _WriteString $fp $filterSerialNum 32
            _WriteString $fp " " 64

            # Section Object Parameter
            _WriteFloat  $fp $emissivity
            _WriteFloat  $fp $objectDistance
            _WriteFloat  $fp $apparentTemp 
            _WriteFloat  $fp $atmosphereTemp
            _WriteFloat  $fp $relativeHumidity
            _WriteFloat  $fp $computedAtmTrans
            _WriteFloat  $fp $estimatedAtmTrans
            _WriteFloat  $fp $referenceTemp
            _WriteFloat  $fp $extOpticsTemp
            _WriteFloat  $fp $extOpticsTrans
            _WriteString $fp " " 64

            # Section DateAndTime
            _WriteInt $fp [_GetAsInt $year]
            _WriteInt $fp [_GetAsInt $month]
            _WriteInt $fp [_GetAsInt $day]
            _WriteInt $fp [_GetAsInt $hour]
            _WriteInt $fp [_GetAsInt $minute]
            _WriteInt $fp [_GetAsInt $second]
            _WriteInt $fp $millisecond
            _WriteString $fp " " 64

            # Section Scaling
            _WriteFloat $fp $cameraScaleMin
            _WriteFloat $fp $cameraScaleMax
            _WriteFloat $fp $calculatedScaleMin
            _WriteFloat $fp $calculatedScaleMax 
            _WriteFloat $fp $actualScaleMin
            _WriteFloat $fp $actualScaleMax
            _WriteString $fp " " 192
        }

        #
        # Image data read/write procedures.
        #

        proc _GetImageData { fp headerDict dataDict } {
            upvar 1 $dataDict myDict

            set numBytes  [dict get $headerDict NumByte]
            set numPixel  [dict get $headerDict NumPixel]
            set numChan   [dict get $headerDict NumChan]
            set pixelType [dict get $headerDict PixelType]
            if { $pixelType eq "short" } {
                # FLIR uses signed short values, so map the pixel values to unsigned short for dict storage.
                set fileName  [dict get $headerDict FileName]
                set retVal [binary scan [read $fp $numBytes] "su${numPixel}" valList]
                if { $retVal != 1 } {
                    close $fp
                    error "Could not scan pixels of image $fileName"
                }
                set imgAsByteArray [binary format s${numPixel} $valList]
                dict set myDict Data $imgAsByteArray
            } else {
                dict set myDict Data [read $fp $numBytes]
                if { [::pawt::GetNativeByteOrder] eq "Motorola" && $pixelType ne "byte" } {
                    pawt SwapImageBytes myDict
                }
            }
        }

        proc _PutImageData { fp imgDict } {
            upvar 1 $imgDict myDict

            set pixelType [dict get $myDict Header PixelType]
            set scanFmt [_GetScanFormat [_GetPixelType $pixelType] "Intel"]
            set imgAsList [pawt GetImageAsList myDict -scanorder "TopDown"]
            puts -nonewline $fp [binary format "${scanFmt}*" $imgAsList]
        }

        proc ReadImageFile { flirImgFile args } {
            # Read a FLIR image file into a dictionary.
            #
            # flirImgFile - File name of the FLIR image.
            # args        - Optional format specific arguments. Currently none.
            #
            # Get the image data as a dictionary containing 2 keys: `Header` and `Data`.
            # * See [::pawt::ReadImageHeader] for the entries of the `Header` key.
            # * See [::pawt::ReadImageFile] for the entries of the `Data` key.
            #
            # Returns the image information as a dictionary.
            # If the file does not exist or no supported image format can be detected,
            # an error is thrown.
            #
            # See also: ReadImageHeader

            set retVal [catch {open $flirImgFile "r"} fp]
            if { $retVal != 0 } {
                error "Cannot open file $flirImgFile"
            }
            fconfigure $fp -translation binary

            set imgDict [dict create]
            set headerDict [_GetImageHeader $fp [file tail $flirImgFile]]
            dict append imgDict Header $headerDict
            _GetImageData $fp $headerDict imgDict

            close $fp
            return $imgDict
        }

        proc WriteImageFile { imgDict flirImgFile args } {
            # Write the values of an image dict into a FLIR image file.
            #
            # imgDict     - Image dictionary.
            # flirImgFile - File name of the image.
            # args        - Optional format specific arguments described below.
            #
            # -writedate <bool> - Write current date into file. Default: true.
            #                     If set to false, the date fields are filled with zeros.
            #
            # See [::pawt::WriteImageFile] for general informations regarding writing images.
            #
            # Returns no value. If invalid options are specified or the file could not
            # be written, an error is thrown.
            #
            # See also: ReadImageFile ReadImageHeader

            set opts [dict create \
                -writedate true \
            ]

            foreach { key value } $args {
                if { [dict exists $opts $key] } {
                    if { $value eq "" } {
                        error "WriteImageFile: No value specified for key \"$key\"."
                    }
                    dict set opts $key $value
                } else {
                    error "WriteImageFile: Unknown option \"$key\" specified."
                }
            }

            set headerDict [dict get $imgDict Header]
            set numChan    [dict get $headerDict NumChan]

            if { $numChan != 1 } {
                error "Write FLIR file: Invalid number of channels: $numChan (must be 1)"
            }

            set retVal [catch {open $flirImgFile "w"} fp]
            if { $retVal != 0 } {
                error "Cannot open output file $flirImgFile"
            }
            fconfigure $fp -translation binary

            _PutImageHeader $fp $headerDict [dict get $opts "-writedate"]
            _PutImageData   $fp imgDict
            close $fp
        }
    }
}
