SixelImage

Program.fs

(*
MIT License

Copyright (c) 2024 Mårten Rånge

Permission is hereby granted, free of charge, to any person obtaining a copy
of this software and associated documentation files (the "Software"), to deal
in the Software without restriction, including without limitation the rights
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
copies of the Software, and to permit persons to whom the Software is
furnished to do so, subject to the following conditions:

The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Software.

THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
SOFTWARE.
*)

open System
open System.Collections.Generic
open System.IO
open System.Text

// I use the excellent SixLabors ImageSharp for image processing
//  Note this library has a split license, basically for open source it's free,
//  in a commercial setting it costs money. 
//  There are more nuances to this, check the license file.
open SixLabors.ImageSharp
open SixLabors.ImageSharp.PixelFormats
open SixLabors.ImageSharp.Processing
open SixLabors.ImageSharp.Processing.Processors.Quantization

open FSharp.Core.Printf

let writeToConsole (cc : ConsoleColor) (prelude : string) (msg : string) =
  let occ = Console.ForegroundColor
  Console.ForegroundColor <- cc
  try
    Console.Write prelude
    Console.Write " - "
    Console.WriteLine msg
  finally
    Console.ForegroundColor <- occ

let good msg = writeToConsole ConsoleColor.Green    "GOOD" msg
let hili msg = writeToConsole ConsoleColor.Cyan     "HILI" msg
let info msg = writeToConsole ConsoleColor.Gray     "INFO" msg
let warn msg = writeToConsole ConsoleColor.Yellow   "WARN" msg
let fail msg = writeToConsole ConsoleColor.Red      "FAIL" msg

let goodf fmt = kprintf good fmt
let hilif fmt = kprintf hili fmt
let infof fmt = kprintf info fmt
let warnf fmt = kprintf warn fmt
let failf fmt = kprintf fail fmt

[<EntryPoint>]
let main args =
  try
    let imagePath       = Path.GetFullPath @"D:\assets\ai-knight-3.jpg"
    let sixelImagePath  = Path.GetFullPath @"D:\assets\sixel.txt"
    // To let you inspect the converted image
    let tempImagePath   = Path.GetFullPath @"D:\assets\temp.png"

    // If special characters shall be escaped
    let escape    = false

    // Currently height must be divisible by 6
    //  Because sixels are six pixels high
    let height    = 44*6
    // Because characters are about twice as high as wide
    let width     = 2*height
    let maxColors = 250

    hilif "Loading image: %s" imagePath
    use image = Image.Load<Rgba32> imagePath

    do
      hilif "Resizing image from %dx%d to: %dx%d" image.Width image.Height width height
      let mutator (ctx : IImageProcessingContext) = 
        let options = ResizeOptions (
            Mode    = ResizeMode.Stretch
          , Sampler = KnownResamplers.Hermite
          , Size    = Size(int width, int height)
          )
        ignore <| ctx.Resize options
      image.Mutate mutator

    do
      hilif "Quantizing image to %d colors" maxColors
      let mutator (ctx : IImageProcessingContext) =
        let options   = QuantizerOptions (MaxColors = maxColors)
        let quantizer = WuQuantizer options
        ignore <| ctx.Quantize quantizer
      image.Mutate mutator

    let palette = Dictionary ()

    do
      hili "Computing palette"
      let pa = 
        PixelAccessorAction<Rgba32> (
          fun a -> 
            for y = 0 to a.Height - 1 do
              let row = a.GetRowSpan y
              for x = 0 to a.Width - 1 do
                let pix = row.[x]
                if pix.A > 127uy then
                  palette.TryAdd (pix.Rgb, palette.Count) |> ignore
        )
      image.ProcessPixelRows pa
      infof "Found %d palette entries" palette.Count
      
    do
      hili "Generating Sixel image"

      let palette = 
        palette
        |> Array.ofSeq
        |> Array.map (fun kv -> kv.Value, kv.Key)
        |> Array.sortBy fst

      let sb = StringBuilder ()

      let inline str (s : string) = sb.Append s |> ignore
      let inline ch  (c : char  ) = sb.Append c |> ignore
      let inline strf fmt         = kprintf str fmt 

      let toTop, sixelPrelude, sixelEpilogue =
        if escape then
          @"\x1B[H", @"\x1BPq", @"\x1B\\"
        else
          "\x1B[H", "\x1BPq", "\x1B\\"

      // Move cursor to top
      str toTop
      // Start the sixel bitmap
      str sixelPrelude

      for i, rgb in palette do
        let inline f (v : byte) = int (round (float v*100./255.))
        strf "#%d;2;%d;%d;%d" i (f rgb.R) (f rgb.G) (f rgb.B)

      let pa = 
        PixelAccessorAction<Rgba32> (
          fun a -> 
            let empty   : int array = Array.zeroCreate a.Width
            let sixels  : int array = Array.zeroCreate a.Width
            for y6 = 0 to a.Height/6-1 do
              let y = y6*6
              for i, rgb in palette do
                Array.Copy (empty, sixels, sixels.Length)
                str ("#" + string i)
                for i = 0 to 5 do
                  let y = y+i
                  let row = a.GetRowSpan y
                  for x = 0 to a.Width-1 do
                    let pix = row.[x]
                    if pix.A > 127uy && pix.Rgb = rgb then
                      sixels.[x] <- sixels.[x] ||| (1 <<< i)

                for x = 0 to a.Width-1 do
                  let tbw = char (63+(sixels.[x]&&&0x3F))
                  ch tbw
                  if escape && tbw = '\\' then
                    ch tbw
                  
                ch '$'
              ch '-'
          )
      image.ProcessPixelRows pa

      // End the sixel bitmap
      str sixelEpilogue

      hilif "Writing sixel image: %s" sixelImagePath
      File.WriteAllText (sixelImagePath, sb.ToString(), Encoding.ASCII)

    do
      hilif "Saving temp image: %s" tempImagePath
      image.SaveAsPng tempImagePath

    good "We are done!"

    0
  with
  | e -> 
    failf "Caught exception: %s" (string e)
    99