CREATE BUF 0 ,              \ single-character look-ahead buffer
CREATE COLUMN# 0 ,
CREATE LINE# 1 ,

: NEWLINE? ( c -- t|f)  DUP 10 = SWAP  13 =  OR ;
: +IN ( c --)
   1 SWAP  NEWLINE?
   IF 0 COLUMN# ! LINE# ELSE COLUMN# THEN
   +!  0 BUF ! ;
: PEEK   BUF @ 0= IF STDIN KEY-FILE BUF ! THEN BUF @ ;
: GETC   PEEK  DUP +IN ;
: SKIP   GETC DROP ;
: .LOCATION   7 .R  4 .R SPACE ;
: WHERE   COLUMN# @ LINE# @ ;
: .WHERE    WHERE .LOCATION ;
: .WHERE+   WHERE  SWAP 1+ SWAP .LOCATION ;

: EXPECT   GETC  OVER OVER =
   IF 2DROP
   ELSE CR ." stdin:" COLUMN# @ 0 LINE# @ 0
      <# #s #> TYPE ." :" <# #s #> TYPE ." : "
      ." unexpected `" EMIT ." ', expecting `" EMIT ." '" CR
      BYE
   THEN ;
: EQ   PEEK [CHAR] = = IF SKIP 2SWAP THEN
       ." Op_" TYPE CR  2DROP ;

CREATE ESC  4 C, CHAR $ C, CHAR $ C, CHAR \ C, 0 C,
: ?ESC?   CR ." Unknown escape sequence `\" EMIT ." '" CR BYE ;
: >ESC   ESC 4 + C!  ESC ;
: $$\n   10 ;
: $$\\   [CHAR] \ ;
: ESCAPE   DUP >ESC FIND IF NIP EXECUTE ELSE DROP ?ESC? THEN ;
: ?ESCAPE   DUP [CHAR] \ = IF DROP GETC ESCAPE THEN ;
: ?EOF   DUP 4 = IF CR ." End-of-file in string" CR BYE THEN ;
: ?EOL   DUP NEWLINE?
         IF CR ." End-of-line in string" CR BYE THEN ;
: STRING   PAD
   BEGIN  GETC ?EOF ?EOL DUP  [CHAR] " <>
   WHILE  OVER C! CHAR+
   REPEAT DROP  PAD TUCK - ;
: "TYPE"   [CHAR] " EMIT  TYPE  [CHAR] " EMIT ;

CREATE TOKEN  4 C, CHAR $ C, CHAR $ C, 0 C, 0 C,
: >HEX   DUP 9 > IF 7 + THEN [CHAR] 0 + ;
: HI!   $F0 AND  2/ 2/ 2/ 2/ >HEX  TOKEN 3 + C! ;
: LO!   $0F AND  >HEX TOKEN 4 + C! ;
: >TOKEN   DUP HI! LO!  TOKEN ;

: ?EOF   DUP 4 = IF CR ." End-of-file in comment" CR BYE THEN ;
: $$2F   PEEK [CHAR] * =
   IF SKIP
       BEGIN
   	GETC ?EOF  [CHAR] * =
   	PEEK [CHAR] / =  AND
       UNTIL  SKIP
   ELSE  .WHERE ." Op_divide" CR THEN ;
: $$22   .WHERE ." String " STRING "TYPE" CR ;
: $$27   .WHERE GETC ?ESCAPE ." Integer " . [CHAR] ' EXPECT CR ;
: $$04   .WHERE ." End_of_input" CR BYE ;
: $$2D   .WHERE ." Op_subtract" CR ;
: $$2B   .WHERE ." Op_add" CR ;
: $$25   .WHERE ." Op_mod" CR ;
: $$2A   .WHERE ." Op_multiply" CR ;
: $$7B   .WHERE ." LeftBrace" CR ;
: $$7D   .WHERE ." RightBrace" CR ;
: $$2C   .WHERE ." Comma" CR ;
: $$29   .WHERE ." RightParen" CR ;
: $$28   .WHERE ." LeftParen" CR ;
: $$3B   .WHERE ." Semicolon" CR ;
: $$3D   .WHERE s" equal" s" assign" EQ ;
: $$21   .WHERE s" notequal" s" not" EQ ;
: $$3C   .WHERE s" lessequal" s" less" EQ ;
: $$3E   .WHERE s" greaterequal" s" greater" EQ ;
: $$26   .WHERE [CHAR] & EXPECT  ." Op_and" CR ;
: $$7C   .WHERE [CHAR] | EXPECT  ." Op_or" CR ;
: $$20   ;   \ space

CREATE KEYWORD  0 C, CHAR $ C, CHAR $ C, 5 CHARS ALLOT
: >KEYWORD   DUP  2 + KEYWORD C!
             KEYWORD 3 + SWAP CMOVE  KEYWORD ;
: FIND-KW   DUP 5 <=
   IF 2DUP >KEYWORD FIND
      IF TRUE 2SWAP 2DROP ELSE DROP FALSE THEN
   ELSE FALSE THEN ;

: $$if   ." Keyword_if" ;
: $$else   ." Keyword_else" ;
: $$while   ." Keyword_while" ;
: $$print   ." Keyword_print" ;
: $$putc   ." Keyword_putc" ;

: DIGIT?   48 58 WITHIN ;
: ALPHA?   DUP  95 = SWAP		  \ underscore?
           DUP 97 123 WITHIN SWAP	  \ lower?
           65 91 WITHIN  OR OR ;	  \ upper?
: ALNUM?   DUP DIGIT? SWAP  ALPHA? OR ;
: INTEGER   0
   BEGIN  PEEK DIGIT?
   WHILE  GETC [CHAR] 0 -  SWAP 10 * +
   REPEAT ;
: ?INTEGER?   CR ." Invalid number" CR BYE ;
: ?INTEGER   PEEK ALPHA? IF ?INTEGER? THEN ;
: DIGIT   .WHERE+ ." Integer " INTEGER ?INTEGER . CR ;
: NAME   PAD
         BEGIN  PEEK ALNUM?
	 WHILE GETC OVER C! CHAR+
	 REPEAT  PAD TUCK - ;
: IDENT   ." Identifier " TYPE ;
: ALPHA   .WHERE+ NAME FIND-KW
          IF EXECUTE ELSE IDENT THEN CR ;
: ?CHAR?   CR ." Character '" EMIT ." ' not recognized" CR BYE ;
: SPACE?   DUP BL = SWAP  9 14 WITHIN  OR ;
: SKIP-SPACE   BEGIN PEEK SPACE? WHILE SKIP REPEAT ;
: CONSUME
   SKIP-SPACE
   PEEK DIGIT? IF DIGIT ELSE
    PEEK ALPHA? IF ALPHA ELSE
     PEEK >TOKEN FIND
     IF SKIP EXECUTE ELSE GETC ?CHAR? BYE THEN
   THEN THEN ;
: TOKENIZE   BEGIN CONSUME AGAIN ;
TOKENIZE


import core.stdc.stdio, std.stdio, std.algorithm, std.typecons,
       std.math, std.range, std.conv, std.string, bitmap;

struct Col { float r, g, b; }
alias Cluster = Tuple!(Col, float, Col, Col[]);
enum Axis { R, G, B }

enum round = (in float x) pure nothrow @safe @nogc => cast(int)floor(x + 0.5);

enum roundRGB = (in Col c) pure nothrow @safe @nogc =>
    RGB(cast(ubyte)round(c.r),
        cast(ubyte)round(c.g),
        cast(ubyte)round(c.b));

enum addRGB = (in Col c1, in Col c2) pure nothrow @safe @nogc =>
    Col(c1.r + c2.r, c1.g + c2.g, c1.b + c2.b);

Col meanRGB(in Col[] pxList) pure nothrow @safe @nogc {
    immutable tot = reduce!addRGB(Col(0, 0, 0), pxList);
    immutable n = pxList.length;
    return Col(tot.r / n, tot.g / n, tot.b / n);
}

enum minC = (in Col c1, in Col c2) pure nothrow @safe @nogc =>
    Col(min(c1.r, c2.r), min(c1.g, c2.g), min(c1.b, c2.b));

enum maxC = (in Col c1, in Col c2) pure nothrow @safe @nogc =>
    Col(max(c1.r, c2.r), max(c1.g, c2.g), max(c1.b, c2.b));

Tuple!(Col, Col) extrems(in Col[] lst) pure nothrow @safe @nogc {
    enum FI = float.infinity;
    auto mmRGB = typeof(return)(Col(FI, FI, FI), Col(-FI, -FI, -FI));
    return reduce!(minC, maxC)(mmRGB, lst);
}

Tuple!(float, Col) volumeAndDims(in Col[] lst) pure nothrow @safe @nogc {
    immutable e = lst.extrems;
    immutable r = Col(e[1].r - e[0].r,
                      e[1].g - e[0].g,
                      e[1].b - e[0].b);
    return typeof(return)(r.r * r.g * r.b, r);
}

Cluster makeCluster(Col[] pixelList) pure nothrow @safe @nogc {
    immutable vol_dims = pixelList.volumeAndDims;
    immutable int len = pixelList.length;
    return typeof(return)(pixelList.meanRGB,
                          len * vol_dims[0],
                          vol_dims[1],
                          pixelList);
}

enum fCmp = (in float a, in float b) pure nothrow @safe @nogc =>
    (a > b) ? 1 : (a < b ? -1 : 0);

Axis largestAxis(in Col c) pure nothrow @safe @nogc {
    immutable int r1 = fCmp(c.r, c.g);
    immutable int r2 = fCmp(c.r, c.b);
    if (r1 ==  1 && r2 ==  1) return Axis.R;
    if (r1 == -1 && r2 ==  1) return Axis.G;
    if (r1 ==  1 && r2 == -1) return Axis.B;
    return (fCmp(c.g, c.b) == 1) ? Axis.G : Axis.B;
}

Tuple!(Cluster, Cluster) subdivide(in Col c, in float nVolProd,
                                   in Col vol, Col[] pixels)
pure nothrow @safe @nogc {
    Col[] px2;
    final switch (largestAxis(vol)) {
        case Axis.R: px2 = pixels.partition!(c1 => c1.r < c.r); break;
        case Axis.G: px2 = pixels.partition!(c1 => c1.g < c.g); break;
        case Axis.B: px2 = pixels.partition!(c1 => c1.b < c.b); break;
    }
    auto px1 = pixels[0 .. $ - px2.length];
    return typeof(return)(px1.makeCluster, px2.makeCluster);
}

uint RGB2uint(in RGB c) pure nothrow @safe @nogc {
    return c.r | (c.g << 8) | (c.b << 16);
}

enum uintToRGB = (in uint c) pure nothrow @safe @nogc =>
    RGB(c & 0xFF, (c >> 8) & 0xFF, (c >> 16) & 0xFF);

Image!RGB colorQuantize(in Image!RGB img, in int n) pure nothrow /*@safe*/ {
    immutable width = img.nx;
    immutable height = img.ny;

    auto cols = new Col[width * height];
    foreach (immutable i, ref c; img.image)
        cols[i] = Col(c.tupleof);

    immutable dumb = Col(0, 0, 0);
    Cluster unused = Cluster(dumb, -float.infinity, dumb, (Col[]).init);

    auto clusters = [cols.makeCluster];
    while (clusters.length < n) {
        // Cluster cl = clusters.reduce!(max!q{ a[1] })(unused);
        Cluster cl = reduce!((c1, c2) => c1[1] > c2[1] ? c1 : c2)
                            (unused, clusters);
        clusters = [cl[].subdivide[]] ~
            clusters.remove!(c => c == cl, SwapStrategy.unstable); //**
    }

    uint[uint] pixMap; // Faster than RGB[RGB].
    ubyte[4] u4a, u4b;
    foreach (const cluster; clusters) {
        immutable ubyteMean = cluster[0].roundRGB.RGB2uint;
        foreach (immutable col; cluster[3])
            pixMap[col.roundRGB.RGB2uint] = ubyteMean;
    }

    auto result = new Image!RGB;
    result.allocate(height, width);

    foreach (immutable i, immutable p; img.image) {
        immutable u3a = p.tupleof.RGB;
        result.image[i] = pixMap[RGB2uint(u3a)].uintToRGB;
    }

    return result;
}

void main(in string[] args) {
    string fileName;
    int nCols;
    switch (args.length) {
        case 1:
            fileName = "quantum_frog.ppm";
            nCols = 16;
            break;
        case 3:
            fileName = args[1];
            nCols = args[2].to!int;
            break;
        default:
            "Usage: color_quantization image.ppm ncolors".writeln;
            return;
    }

    auto im = new Image!RGB;
    im.loadPPM6(fileName);
    const imq = colorQuantize(im, nCols);
    imq.savePPM6("quantum_frog_quantized.ppm");
}


!!!
!!! An implementation of the Rosetta Code lexical analyzer task:
!!! https://rosettacode.org/wiki/Compiler/lexical_analyzer
!!!
!!! The C implementation was used as a reference on behavior, but was
!!! not adhered to for the implementation.
!!!

module string_buffers
  use, intrinsic :: iso_fortran_env, only: error_unit
  use, intrinsic :: iso_fortran_env, only: int64

  implicit none
  private

  public :: strbuf_t
  public :: strbuf_t_length_kind
  public :: strbuf_t_character_kind

  integer, parameter :: strbuf_t_length_kind = int64

  ! String buffers can handle Unicode.
  integer, parameter :: strbuf_t_character_kind = selected_char_kind ('ISO_10646')

  ! Private abbreviations.
  integer, parameter :: nk = strbuf_t_length_kind
  integer, parameter :: ck = strbuf_t_character_kind

  type :: strbuf_t
     integer(kind = nk), private :: len = 0
     !
     ! ‘chars’ is made public for efficient access to the individual
     ! characters.
     !
     character(1, kind = ck), allocatable, public :: chars(:)
   contains
     procedure, pass, private :: ensure_storage => strbuf_t_ensure_storage
     procedure, pass :: to_unicode => strbuf_t_to_unicode
     procedure, pass :: length => strbuf_t_length
     procedure, pass :: set => strbuf_t_set
     procedure, pass :: append => strbuf_t_append
     generic :: assignment(=) => set
  end type strbuf_t

contains

  function strbuf_t_to_unicode (strbuf) result (s)
    class(strbuf_t), intent(in) :: strbuf
    character(:, kind = ck), allocatable :: s

    !
    ! This does not actually ensure that the string is valid Unicode;
    ! any 31-bit ‘character’ is supported.
    !

    integer(kind = nk) :: i

    allocate (character(len = strbuf%len, kind = ck) :: s)
    do i = 1, strbuf%len
       s(i:i) = strbuf%chars(i)
    end do
  end function strbuf_t_to_unicode

  elemental function strbuf_t_length (strbuf) result (n)
    class(strbuf_t), intent(in) :: strbuf
    integer(kind = nk) :: n

    n = strbuf%len
  end function strbuf_t_length

  elemental function next_power_of_two (x) result (y)
    integer(kind = nk), intent(in) :: x
    integer(kind = nk) :: y

    !
    ! It is assumed that no more than 64 bits are used.
    !
    ! The branch-free algorithm is that of
    ! https://archive.is/nKxAc#RoundUpPowerOf2
    !
    ! Fill in bits until one less than the desired power of two is
    ! reached, and then add one.
    !

    y = x - 1
    y = ior (y, ishft (y, -1))
    y = ior (y, ishft (y, -2))
    y = ior (y, ishft (y, -4))
    y = ior (y, ishft (y, -8))
    y = ior (y, ishft (y, -16))
    y = ior (y, ishft (y, -32))
    y = y + 1
  end function next_power_of_two

  elemental function new_storage_size (length_needed) result (size)
    integer(kind = nk), intent(in) :: length_needed
    integer(kind = nk) :: size

    ! Increase storage by orders of magnitude.

    if (2_nk**32 < length_needed) then
       size = huge (1_nk)
    else
       size = next_power_of_two (length_needed)
    end if
  end function new_storage_size

  subroutine strbuf_t_ensure_storage (strbuf, length_needed)
    class(strbuf_t), intent(inout) :: strbuf
    integer(kind = nk), intent(in) :: length_needed

    integer(kind = nk) :: new_size
    type(strbuf_t) :: new_strbuf

    if (.not. allocated (strbuf%chars)) then
       ! Initialize a new strbuf%chars array.
       new_size = new_storage_size (length_needed)
       allocate (strbuf%chars(1:new_size))
    else if (ubound (strbuf%chars, 1) < length_needed) then
       ! Allocate a new strbuf%chars array, larger than the current
       ! one, but containing the same characters.
       new_size = new_storage_size (length_needed)
       allocate (new_strbuf%chars(1:new_size))
       new_strbuf%chars(1:strbuf%len) = strbuf%chars(1:strbuf%len)
       call move_alloc (new_strbuf%chars, strbuf%chars)
    end if
  end subroutine strbuf_t_ensure_storage

  subroutine strbuf_t_set (dst, src)
    class(strbuf_t), intent(inout) :: dst
    class(*), intent(in) :: src

    integer(kind = nk) :: n
    integer(kind = nk) :: i

    select type (src)
    type is (character(*, kind = ck))
       n = len (src, kind = nk)
       call dst%ensure_storage(n)
       do i = 1, n
          dst%chars(i) = src(i:i)
       end do
       dst%len = n
    type is (character(*))
       n = len (src, kind = nk)
       call dst%ensure_storage(n)
       do i = 1, n
          dst%chars(i) = src(i:i)
       end do
       dst%len = n
    class is (strbuf_t)
       n = src%len
       call dst%ensure_storage(n)
       dst%chars(1:n) = src%chars(1:n)
       dst%len = n
    class default
       error stop
    end select
  end subroutine strbuf_t_set

  subroutine strbuf_t_append (dst, src)
    class(strbuf_t), intent(inout) :: dst
    class(*), intent(in) :: src

    integer(kind = nk) :: n_dst, n_src, n
    integer(kind = nk) :: i

    select type (src)
    type is (character(*, kind = ck))
       n_dst = dst%len
       n_src = len (src, kind = nk)
       n = n_dst + n_src
       call dst%ensure_storage(n)
       do i = 1, n_src
          dst%chars(n_dst + i) = src(i:i)
       end do
       dst%len = n
    type is (character(*))
       n_dst = dst%len
       n_src = len (src, kind = nk)
       n = n_dst + n_src
       call dst%ensure_storage(n)
       do i = 1, n_src
          dst%chars(n_dst + i) = src(i:i)
       end do
       dst%len = n
    class is (strbuf_t)
       n_dst = dst%len
       n_src = src%len
       n = n_dst + n_src
       call dst%ensure_storage(n)
       dst%chars((n_dst + 1):n) = src%chars(1:n_src)
       dst%len = n
    class default
       error stop
    end select
  end subroutine strbuf_t_append

end module string_buffers

module lexical_analysis
  use, intrinsic :: iso_fortran_env, only: input_unit
  use, intrinsic :: iso_fortran_env, only: output_unit
  use, intrinsic :: iso_fortran_env, only: error_unit
  use, intrinsic :: iso_fortran_env, only: int32
  use, non_intrinsic :: string_buffers

  implicit none
  private

  public :: lexer_input_t
  public :: lexer_output_t
  public :: run_lexer

  integer, parameter :: input_file_unit_no = 100
  integer, parameter :: output_file_unit_no = 101

  ! Private abbreviations.
  integer, parameter :: nk = strbuf_t_length_kind
  integer, parameter :: ck = strbuf_t_character_kind

  ! Integers large enough for a Unicode code point. Unicode code
  ! points (and UCS-4) have never been allowed to go higher than
  ! 7FFFFFFF, and are even further restricted now.
  integer, parameter :: ichar_kind = int32

  character(1, kind = ck), parameter :: horizontal_tab_char = char (9, kind = ck)
  character(1, kind = ck), parameter :: linefeed_char = char (10, kind = ck)
  character(1, kind = ck), parameter :: vertical_tab_char = char (11, kind = ck)
  character(1, kind = ck), parameter :: formfeed_char = char (12, kind = ck)
  character(1, kind = ck), parameter :: carriage_return_char = char (13, kind = ck)
  character(1, kind = ck), parameter :: space_char = ck_' '

  ! The following is correct for Unix and its relatives.
  character(1, kind = ck), parameter :: newline_char = linefeed_char

  character(1, kind = ck), parameter :: backslash_char = char (92, kind = ck)

  character(*, kind = ck), parameter :: newline_intstring = ck_'10'
  character(*, kind = ck), parameter :: backslash_intstring = ck_'92'

  integer, parameter :: tk_EOI = 0
  integer, parameter :: tk_Mul = 1
  integer, parameter :: tk_Div = 2
  integer, parameter :: tk_Mod = 3
  integer, parameter :: tk_Add = 4
  integer, parameter :: tk_Sub = 5
  integer, parameter :: tk_Negate = 6
  integer, parameter :: tk_Not = 7
  integer, parameter :: tk_Lss = 8
  integer, parameter :: tk_Leq = 9
  integer, parameter :: tk_Gtr = 10
  integer, parameter :: tk_Geq = 11
  integer, parameter :: tk_Eq = 12
  integer, parameter :: tk_Neq = 13
  integer, parameter :: tk_Assign = 14
  integer, parameter :: tk_And = 15
  integer, parameter :: tk_Or = 16
  integer, parameter :: tk_If = 17
  integer, parameter :: tk_Else = 18
  integer, parameter :: tk_While = 19
  integer, parameter :: tk_Print = 20
  integer, parameter :: tk_Putc = 21
  integer, parameter :: tk_Lparen = 22
  integer, parameter :: tk_Rparen = 23
  integer, parameter :: tk_Lbrace = 24
  integer, parameter :: tk_Rbrace = 25
  integer, parameter :: tk_Semi = 26
  integer, parameter :: tk_Comma = 27
  integer, parameter :: tk_Ident = 28
  integer, parameter :: tk_Integer = 29
  integer, parameter :: tk_String = 30

  character(len = 16), parameter :: token_names(0:30) = &
       & (/ "End_of_input    ", "Op_multiply     ", "Op_divide       ", "Op_mod          ", "Op_add          ", &
       &    "Op_subtract     ", "Op_negate       ", "Op_not          ", "Op_less         ", "Op_lessequal    ", &
       &    "Op_greater      ", "Op_greaterequal ", "Op_equal        ", "Op_notequal     ", "Op_assign       ", &
       &    "Op_and          ", "Op_or           ", "Keyword_if      ", "Keyword_else    ", "Keyword_while   ", &
       &    "Keyword_print   ", "Keyword_putc    ", "LeftParen       ", "RightParen      ", "LeftBrace       ", &
       &    "RightBrace      ", "Semicolon       ", "Comma           ", "Identifier      ", "Integer         ", &
       &    "String          " /)

  type :: token_t
     integer :: token_no

     ! Our implementation stores the value of a tk_Integer as a
     ! string. The C reference implementation stores it as an int.
     character(:, kind = ck), allocatable :: val

     integer(nk) :: line_no
     integer(nk) :: column_no
  end type token_t

  type :: lexer_input_t
     logical, private :: using_input_unit = .true.
     integer, private :: unit_no = -(huge (1))
     integer(kind = nk) :: line_no = 1
     integer(kind = nk) :: column_no = 0
     integer, private :: unget_count = 0

     ! The maximum lookahead is 2, although I believe we are using
     ! only 1. In principle, the lookahead could be any finite number.
     character(1, kind = ck), private :: unget_buffer(1:2)
     logical, private :: unget_eof_buffer(1:2)

     ! Using the same strbuf_t multiple times reduces the need for
     ! reallocations. Putting that strbuf_t in the lexer_input_t is
     ! simply for convenience.
     type(strbuf_t), private :: strbuf

   contains
     !
     ! Note: There is currently no facility for closing one input and
     !       switching to another.
     !
     ! Note: There is currently no facility to decode inputs into
     !       Unicode codepoints. Instead, what happens is raw bytes of
     !       input get stored as strbuf_t_character_kind values. This
     !       behavior is adequate for ASCII inputs.
     !
     procedure, pass :: use_file => lexer_input_t_use_file
     procedure, pass :: get_next_ch => lexer_input_t_get_next_ch
     procedure, pass :: unget_ch => lexer_input_t_unget_ch
     procedure, pass :: unget_eof => lexer_input_t_unget_eof
  end type lexer_input_t

  type :: lexer_output_t
     integer, private :: unit_no = output_unit
   contains
     procedure, pass :: use_file => lexer_output_t_use_file
     procedure, pass :: output_token => lexer_output_t_output_token
  end type lexer_output_t

contains

  subroutine lexer_input_t_use_file (inputter, filename)
    class(lexer_input_t), intent(inout) :: inputter
    character(*), intent(in) :: filename

    integer :: stat

    inputter%using_input_unit = .false.
    inputter%unit_no = input_file_unit_no
    inputter%line_no = 1
    inputter%column_no = 0

    open (unit = input_file_unit_no, file = filename, status = 'old', &
         & action = 'read', access = 'stream', form = 'unformatted',  &
         & iostat = stat)
    if (stat /= 0) then
       write (error_unit, '("Error: failed to open ", A, " for input")') filename
       stop 1
    end if
  end subroutine lexer_input_t_use_file

!!!
!!! If you tell gfortran you want -std=f2008 or -std=f2018, you likely
!!! will need to add also -fall-intrinsics or -U__GFORTRAN__
!!!
!!! The first way, you get the FGETC intrinsic. The latter way, you
!!! get the C interface code that uses getchar(3).
!!!
#ifdef __GFORTRAN__

  subroutine get_input_unit_char (c, stat)
    !
    ! The following works if you are using gfortran.
    !
    ! (FGETC is considered a feature for backwards compatibility with
    ! g77. However, I know of no way to reconfigure input_unit as a
    ! Fortran 2003 stream, for use with ordinary ‘read’.)
    !
    character, intent(inout) :: c
    integer, intent(out) :: stat

    call fgetc (input_unit, c, stat)
  end subroutine get_input_unit_char

#else

  subroutine get_input_unit_char (c, stat)
    !
    ! An alternative implementation of get_input_unit_char. This
    ! actually reads input from the C standard input, which might not
    ! be the same as input_unit.
    !
    use, intrinsic :: iso_c_binding, only: c_int
    character, intent(inout) :: c
    integer, intent(out) :: stat

    interface
       !
       ! Use getchar(3) to read characters from standard input. This
       ! assumes there is actually such a function available, and that
       ! getchar(3) does not exist solely as a macro. (One could write
       ! one’s own getchar() if necessary, of course.)
       !
       function getchar () result (c) bind (c, name = 'getchar')
         use, intrinsic :: iso_c_binding, only: c_int
         integer(kind = c_int) :: c
       end function getchar
    end interface

    integer(kind = c_int) :: i_char

    i_char = getchar ()
    !
    ! The C standard requires that EOF have a negative value. If the
    ! value returned by getchar(3) is not EOF, then it will be
    ! representable as an unsigned char. Therefore, to check for end
    ! of file, one need only test whether i_char is negative.
    !
    if (i_char < 0) then
       stat = -1
    else
       stat = 0
       c = char (i_char)
    end if
  end subroutine get_input_unit_char

#endif

  subroutine lexer_input_t_get_next_ch (inputter, eof, ch)
    class(lexer_input_t), intent(inout) :: inputter
    logical, intent(out) :: eof
    character(1, kind = ck), intent(inout) :: ch

    integer :: stat
    character(1) :: c = '*'

    if (0 < inputter%unget_count) then
       if (inputter%unget_eof_buffer(inputter%unget_count)) then
          eof = .true.
       else
          eof = .false.
          ch = inputter%unget_buffer(inputter%unget_count)
       end if
       inputter%unget_count = inputter%unget_count - 1
    else
       if (inputter%using_input_unit) then
          call get_input_unit_char (c, stat)
       else
          read (unit = inputter%unit_no, iostat = stat) c
       end if

       ch = char (ichar (c, kind = ichar_kind), kind = ck)

       if (0 < stat) then
          write (error_unit, '("Input error with status code ", I0)') stat
          stop 1
       else if (stat < 0) then
          eof = .true.
          ! The C reference code increases column number on end of file;
          ! therefore, so shall we.
          inputter%column_no = inputter%column_no + 1
       else
          eof = .false.
          if (ch == newline_char) then
             inputter%line_no = inputter%line_no + 1
             inputter%column_no = 0
          else
             inputter%column_no = inputter%column_no + 1
          end if
       end if
    end if
  end subroutine lexer_input_t_get_next_ch

  subroutine lexer_input_t_unget_ch (inputter, ch)
    class(lexer_input_t), intent(inout) :: inputter
    character(1, kind = ck), intent(in) :: ch

    if (ubound (inputter%unget_buffer, 1) <= inputter%unget_count) then
       write (error_unit, '("class(lexer_input_t) unget buffer overflow")')
       stop 1
    else
       inputter%unget_count = inputter%unget_count + 1
       inputter%unget_buffer(inputter%unget_count) = ch
       inputter%unget_eof_buffer(inputter%unget_count) = .false.
    end if
  end subroutine lexer_input_t_unget_ch

  subroutine lexer_input_t_unget_eof (inputter)
    class(lexer_input_t), intent(inout) :: inputter

    if (ubound (inputter%unget_buffer, 1) <= inputter%unget_count) then
       write (error_unit, '("class(lexer_input_t) unget buffer overflow")')
       stop 1
    else
       inputter%unget_count = inputter%unget_count + 1
       inputter%unget_buffer(inputter%unget_count) = ck_'*'
       inputter%unget_eof_buffer(inputter%unget_count) = .true.
    end if
  end subroutine lexer_input_t_unget_eof

  subroutine lexer_output_t_use_file (outputter, filename)
    class(lexer_output_t), intent(inout) :: outputter
    character(*), intent(in) :: filename

    integer :: stat

    outputter%unit_no = output_file_unit_no
    open (unit = output_file_unit_no, file = filename, action = 'write', iostat = stat)
    if (stat /= 0) then
       write (error_unit, '("Error: failed to open ", A, " for output")') filename
       stop 1
    end if
  end subroutine lexer_output_t_use_file

  subroutine lexer_output_t_output_token (outputter, token)
    class(lexer_output_t), intent(inout) :: outputter
    class(token_t), intent(in) :: token

    select case (token%token_no)
    case (tk_Integer, tk_Ident, tk_String)
       write (outputter%unit_no, '(1X, I20, 1X, I20, 1X, A, 1X, A)')  &
            &    token%line_no, token%column_no,                      &
            &    token_names(token%token_no), token%val
    case default
       write (outputter%unit_no, '(1X, I20, 1X, I20, 1X, A)')         &
            &    token%line_no, token%column_no,                      &
            &    trim (token_names(token%token_no))
    end select
  end subroutine lexer_output_t_output_token

  subroutine run_lexer (inputter, outputter)
    class(lexer_input_t), intent(inout) :: inputter
    class(lexer_output_t), intent(inout) :: outputter

    type(token_t) :: token

    token = get_token (inputter)
    do while (token%token_no /= tk_EOI)
       call outputter%output_token (token)
       token = get_token (inputter)
    end do
    call outputter%output_token (token)
  end subroutine run_lexer

  function get_token (inputter) result (token)
    class(lexer_input_t), intent(inout) :: inputter
    type(token_t) :: token

    logical :: eof
    character(1, kind = ck) :: ch

    call skip_spaces_and_comments (inputter, eof, ch,              &
         &                         token%line_no, token%column_no)

    if (eof) then
       token%token_no = tk_EOI
    else
       select case (ch)
       case (ck_'{')
          token%token_no = tk_Lbrace
       case (ck_'}')
          token%token_no = tk_Rbrace
       case (ck_'(')
          token%token_no = tk_Lparen
       case (ck_')')
          token%token_no = tk_Rparen
       case (ck_'+')
          token%token_no = tk_Add
       case (ck_'-')
          token%token_no = tk_Sub
       case (ck_'*')
          token%token_no = tk_Mul
       case (ck_'%')
          token%token_no = tk_Mod
       case (ck_';')
          token%token_no = tk_Semi
       case (ck_',')
          token%token_no = tk_Comma
       case (ck_'/')
          token%token_no = tk_Div

       case (ck_"'")
          call read_character_literal

       case (ck_'<')
          call distinguish_operators (ch, ck_'=', tk_Leq, tk_Lss)
       case (ck_'>')
          call distinguish_operators (ch, ck_'=', tk_Geq, tk_Gtr)
       case (ck_'=')
          call distinguish_operators (ch, ck_'=', tk_Eq, tk_Assign)
       case (ck_'!')
          call distinguish_operators (ch, ck_'=', tk_Neq, tk_Not)
       case (ck_'&')
          call distinguish_operators (ch, ck_'&', tk_And, tk_EOI)
       case (ck_'|')
          call distinguish_operators (ch, ck_'|', tk_Or, tk_EOI)

       case (ck_'"')
          call read_string_literal (ch, ch)

       case default
          if (isdigit (ch)) then
             call read_numeric_literal (ch)
          else if (isalpha_or_underscore (ch)) then
             call read_identifier_or_keyword (ch)
          else
             call start_error_message (inputter)
             write (error_unit, '("unrecognized character ''", A, "''")') ch
             stop 1
          end if
       end select
    end if
  contains

    subroutine read_character_literal
      character(1, kind = ck) :: ch
      logical :: eof
      character(20, kind = ck) :: buffer

      token%token_no = tk_Integer

      call inputter%get_next_ch (eof, ch)
      if (eof) then
         call start_error_message (inputter)
         write (error_unit, '("end of input in character literal")')
         stop 1
      else if (ch == ck_"'") then
         call start_error_message (inputter)
         write (error_unit, '("empty character literal")')
         stop 1
      else if (ch == backslash_char) then
         call inputter%get_next_ch (eof, ch)
         if (eof) then
            call start_error_message (inputter)
            write (error_unit, '("end of input in character literal, after backslash")')
            stop 1
         else if (ch == ck_'n') then
            allocate (token%val, source = newline_intstring)
         else if (ch == backslash_char) then
            allocate (token%val, source = backslash_intstring)
         else
            call start_error_message (inputter)
            write (error_unit, '("unknown escape sequence ''", A, A, "'' in character literal")') &
                 &    backslash_char, ch
            stop 1
         end if
         call read_character_literal_close_quote
      else
         call read_character_literal_close_quote
         write (buffer, '(I0)') ichar (ch, kind = ichar_kind)
         allocate (token%val, source = trim (buffer))
      end if
    end subroutine read_character_literal

    subroutine read_character_literal_close_quote
      logical :: eof
      character(1, kind = ck) :: close_quote

      call inputter%get_next_ch (eof, close_quote)
      if (eof) then
         call start_error_message (inputter)
         write (error_unit, '("end of input in character literal")')
         stop 1
      else if (close_quote /= ck_"'") then
         call start_error_message (inputter)
         write (error_unit, '("multi-character literal")')
         stop 1
      end if
    end subroutine read_character_literal_close_quote

    subroutine distinguish_operators (first_ch, second_ch,      &
         &                            token_no_if_second_ch,    &
         &                            token_no_if_no_second_ch)
      character(1, kind = ck), intent(in) :: first_ch
      character(1, kind = ck), intent(in) :: second_ch
      integer, intent(in) :: token_no_if_second_ch
      integer, intent(in) :: token_no_if_no_second_ch

      character(1, kind = ck) :: ch
      logical :: eof

      call inputter%get_next_ch (eof, ch)
      if (eof) then
         call inputter%unget_eof
         token%token_no = token_no_if_no_second_ch
      else if (ch == second_ch) then
         token%token_no = token_no_if_second_ch
      else if (token_no_if_no_second_ch == tk_EOI) then
         call start_error_message (inputter)
         write (error_unit, '("unrecognized character ''", A, "''")') first_ch
         stop 1
      else
         call inputter%unget_ch (ch)
         token%token_no = token_no_if_no_second_ch
      end if
    end subroutine distinguish_operators

    subroutine read_string_literal (opening_quote, closing_quote)
      character(1, kind = ck), intent(in) :: opening_quote
      character(1, kind = ck), intent(in) :: closing_quote

      character(1, kind = ck) :: ch
      logical :: done

      inputter%strbuf = opening_quote
      done = .false.
      do while (.not. done)
         call inputter%get_next_ch (eof, ch)
         if (eof) then
            call start_error_message (inputter)
            write (error_unit, '("end of input in string literal")')
            stop 1
         else if (ch == closing_quote) then
            call inputter%strbuf%append(ch)
            done = .true.
         else if (ch == newline_char) then
            call start_error_message (inputter)
            write (error_unit, '("end of line in string literal")')
            stop 1
         else
            call inputter%strbuf%append(ch)
         end if
      end do
      allocate (token%val, source = inputter%strbuf%to_unicode())
      token%token_no = tk_String
    end subroutine read_string_literal

    subroutine read_numeric_literal (first_ch)
      character(1, kind = ck), intent(in) :: first_ch

      character(1, kind = ck) :: ch

      token%token_no = tk_Integer

      inputter%strbuf = first_ch
      call inputter%get_next_ch (eof, ch)
      do while (isdigit (ch))
         call inputter%strbuf%append (ch)
         call inputter%get_next_ch (eof, ch)
      end do
      if (isalpha_or_underscore (ch)) then
         call start_error_message (inputter)
         write (error_unit, '("invalid numeric literal """, A, """")') &
              &    inputter%strbuf%to_unicode()
         stop 1
      else
         call inputter%unget_ch (ch)
         allocate (token%val, source = inputter%strbuf%to_unicode())
      end if
    end subroutine read_numeric_literal

    subroutine read_identifier_or_keyword (first_ch)
      character(1, kind = ck), intent(in) :: first_ch

      character(1, kind = ck) :: ch

      inputter%strbuf = first_ch
      call inputter%get_next_ch (eof, ch)
      do while (isalnum_or_underscore (ch))
         call inputter%strbuf%append (ch)
         call inputter%get_next_ch (eof, ch)
      end do

      call inputter%unget_ch (ch)

      !
      ! The following is a handwritten ‘implicit radix tree’ search
      ! for keywords, first partitioning the set of keywords according
      ! to their lengths.
      !
      ! I did it this way for fun. One could, of course, write a
      ! program to generate code for such a search.
      !
      ! Perfect hashes are another method one could use.
      !
      ! The reference C implementation uses a binary search.
      !
      token%token_no = tk_Ident
      select case (inputter%strbuf%length())
      case (2)
         select case (inputter%strbuf%chars(1))
         case (ck_'i')
            select case (inputter%strbuf%chars(2))
            case (ck_'f')
               token%token_no = tk_If
            case default
               continue
            end select
         case default
            continue
         end select
      case (4)
         select case (inputter%strbuf%chars(1))
         case (ck_'e')
            select case (inputter%strbuf%chars(2))
            case (ck_'l')
               select case (inputter%strbuf%chars(3))
               case (ck_'s')
                  select case (inputter%strbuf%chars(4))
                  case (ck_'e')
                     token%token_no = tk_Else
                  case default
                     continue
                  end select
               case default
                  continue
               end select
            case default
               continue
            end select
         case (ck_'p')
            select case (inputter%strbuf%chars(2))
            case (ck_'u')
               select case (inputter%strbuf%chars(3))
               case (ck_'t')
                  select case (inputter%strbuf%chars(4))
                  case (ck_'c')
                     token%token_no = tk_Putc
                  case default
                     continue
                  end select
               case default
                  continue
               end select
            case default
               continue
            end select
         case default
            continue
         end select
      case (5)
         select case (inputter%strbuf%chars(1))
         case (ck_'p')
            select case (inputter%strbuf%chars(2))
            case (ck_'r')
               select case (inputter%strbuf%chars(3))
               case (ck_'i')
                  select case (inputter%strbuf%chars(4))
                  case (ck_'n')
                     select case (inputter%strbuf%chars(5))
                     case (ck_'t')
                        token%token_no = tk_Print
                     case default
                        continue
                     end select
                  case default
                     continue
                  end select
               case default
                  continue
               end select
            case default
               continue
            end select
         case (ck_'w')
            select case (inputter%strbuf%chars(2))
            case (ck_'h')
               select case (inputter%strbuf%chars(3))
               case (ck_'i')
                  select case (inputter%strbuf%chars(4))
                  case (ck_'l')
                     select case (inputter%strbuf%chars(5))
                     case (ck_'e')
                        token%token_no = tk_While
                     case default
                        continue
                     end select
                  case default
                     continue
                  end select
               case default
                  continue
               end select
            case default
               continue
            end select
         case default
            continue
         end select
      case default
         continue
      end select
      if (token%token_no == tk_Ident) then
         allocate (token%val, source = inputter%strbuf%to_unicode ())
      end if
    end subroutine read_identifier_or_keyword

  end function get_token

  subroutine skip_spaces_and_comments (inputter, eof, ch, line_no, column_no)
    !
    ! This procedure skips spaces and comments, and also captures the
    ! line and column numbers at the correct moment to indicate the
    ! start of a token.
    !
    class(lexer_input_t), intent(inout) :: inputter
    logical, intent(out) :: eof
    character(1, kind = ck), intent(inout) :: ch
    integer(kind = nk), intent(out) :: line_no
    integer(kind = nk), intent(out) :: column_no

    integer(kind = nk), parameter :: not_done = -(huge (1_nk))

    line_no = not_done
    do while (line_no == not_done)
       call inputter%get_next_ch (eof, ch)
       if (eof) then
          line_no = inputter%line_no
          column_no = inputter%column_no
       else if (ch == ck_'/') then
          line_no = inputter%line_no
          column_no = inputter%column_no
          call inputter%get_next_ch (eof, ch)
          if (eof) then
             call inputter%unget_eof
             ch = ck_'/'
          else if (ch /= ck_'*') then
             call inputter%unget_ch (ch)
             ch = ck_'/'
          else
             call read_to_end_of_comment
             line_no = not_done
          end if
       else if (.not. isspace (ch)) then
          line_no = inputter%line_no
          column_no = inputter%column_no
       end if
    end do

  contains

    subroutine read_to_end_of_comment
      logical :: done

      done = .false.
      do while (.not. done)
         call inputter%get_next_ch (eof, ch)
         if (eof) then
            call end_of_input_in_comment
         else if (ch == ck_'*') then
            call inputter%get_next_ch (eof, ch)
            if (eof) then
               call end_of_input_in_comment
            else if (ch == ck_'/') then
               done = .true.
            end if
         end if
      end do
    end subroutine read_to_end_of_comment

    subroutine end_of_input_in_comment
      call start_error_message (inputter)
      write (error_unit, '("end of input in comment")')
      stop 1
    end subroutine end_of_input_in_comment

  end subroutine skip_spaces_and_comments

  subroutine start_error_message (inputter)
    class(lexer_input_t), intent(inout) :: inputter

    write (error_unit, '("Lexical error at ", I0, ".", I0, ": ")', advance = 'no') &
         &    inputter%line_no, inputter%column_no
  end subroutine start_error_message

  elemental function isspace (ch) result (bool)
    character(1, kind = ck), intent(in) :: ch
    logical :: bool

    bool = (ch == horizontal_tab_char) .or.  &
         & (ch == linefeed_char) .or.        &
         & (ch == vertical_tab_char) .or.    &
         & (ch == formfeed_char) .or.        &
         & (ch == carriage_return_char) .or. &
         & (ch == space_char)
  end function isspace

  elemental function isupper (ch) result (bool)
    character(1, kind = ck), intent(in) :: ch
    logical :: bool

    integer(kind = ichar_kind), parameter :: uppercase_A = ichar (ck_'A', kind = ichar_kind)
    integer(kind = ichar_kind), parameter :: uppercase_Z = ichar (ck_'Z', kind = ichar_kind)

    integer(kind = ichar_kind) :: i_ch

    i_ch = ichar (ch, kind = ichar_kind)
    bool = (uppercase_A <= i_ch .and. i_ch <= uppercase_Z)
  end function isupper

  elemental function islower (ch) result (bool)
    character(1, kind = ck), intent(in) :: ch
    logical :: bool

    integer(kind = ichar_kind), parameter :: lowercase_a = ichar (ck_'a', kind = ichar_kind)
    integer(kind = ichar_kind), parameter :: lowercase_z = ichar (ck_'z', kind = ichar_kind)

    integer(kind = ichar_kind) :: i_ch

    i_ch = ichar (ch, kind = ichar_kind)
    bool = (lowercase_a <= i_ch .and. i_ch <= lowercase_z)
  end function islower

  elemental function isalpha (ch) result (bool)
    character(1, kind = ck), intent(in) :: ch
    logical :: bool

    bool = isupper (ch) .or. islower (ch)
  end function isalpha

  elemental function isdigit (ch) result (bool)
    character(1, kind = ck), intent(in) :: ch
    logical :: bool

    integer(kind = ichar_kind), parameter :: zero = ichar (ck_'0', kind = ichar_kind)
    integer(kind = ichar_kind), parameter :: nine = ichar (ck_'9', kind = ichar_kind)

    integer(kind = ichar_kind) :: i_ch

    i_ch = ichar (ch, kind = ichar_kind)
    bool = (zero <= i_ch .and. i_ch <= nine)
  end function isdigit

  elemental function isalnum (ch) result (bool)
    character(1, kind = ck), intent(in) :: ch
    logical :: bool

    bool = isalpha (ch) .or. isdigit (ch)
  end function isalnum

  elemental function isalpha_or_underscore (ch) result (bool)
    character(1, kind = ck), intent(in) :: ch
    logical :: bool

    bool = isalpha (ch) .or. (ch == ck_'_')
  end function isalpha_or_underscore

  elemental function isalnum_or_underscore (ch) result (bool)
    character(1, kind = ck), intent(in) :: ch
    logical :: bool

    bool = isalnum (ch) .or. (ch == ck_'_')
  end function isalnum_or_underscore

end module lexical_analysis

program lex
  use, intrinsic :: iso_fortran_env, only: output_unit
  use, non_intrinsic :: lexical_analysis

  implicit none

  integer :: arg_count
  character(200) :: arg
  type(lexer_input_t) :: inputter
  type(lexer_output_t) :: outputter

  arg_count = command_argument_count ()
  if (3 <= arg_count) then
     call print_usage
  else if (arg_count == 0) then
     call run_lexer (inputter, outputter)
  else if (arg_count == 1) then
     call get_command_argument (1, arg)
     call inputter%use_file(trim (arg))
     call run_lexer (inputter, outputter)
  else if (arg_count == 2) then
     call get_command_argument (1, arg)
     call inputter%use_file(trim (arg))
     call get_command_argument (2, arg)
     call outputter%use_file(trim (arg))
     call run_lexer (inputter, outputter)
  end if

contains

  subroutine print_usage
    character(200) :: progname

    call get_command_argument (0, progname)
    write (output_unit, '("Usage: ", A, " [INPUT_FILE [OUTPUT_FILE]]")') &
         &      trim (progname)
  end subroutine print_usage

end program lex


package main

import (
    "container/heap"
    "image"
    "image/color"
    "image/png"
    "log"
    "math"
    "os"
    "sort"
)

func main() {
    f, err := os.Open("Quantum_frog.png")
    if err != nil {
        log.Fatal(err)
    }
    img, err := png.Decode(f)
    if ec := f.Close(); err != nil {
        log.Fatal(err)
    } else if ec != nil {
        log.Fatal(ec)
    }
    fq, err := os.Create("frog16.png")
    if err != nil {
        log.Fatal(err)
    }
    if err = png.Encode(fq, quant(img, 16)); err != nil {
        log.Fatal(err)
    }
}

// Organize quatization in some logical steps.
func quant(img image.Image, nq int) image.Image {
    qz := newQuantizer(img, nq) // set up a work space
    qz.cluster()                // cluster pixels by color
    return qz.Paletted()        // generate paletted image from clusters
}

// A workspace with members that can be accessed by methods.
type quantizer struct {
    img image.Image // original image
    cs  []cluster   // len is the desired number of colors
    px  []point     // list of all points in the image
    ch  chValues    // buffer for computing median
    eq  []point     // additional buffer used when splitting cluster
}

type cluster struct {
    px       []point // list of points in the cluster
    widestCh int     // rx, gx, bx const for channel with widest value range
    chRange  uint32  // value range (vmax-vmin) of widest channel
}

type point struct{ x, y int }
type chValues []uint32
type queue []*cluster

const (
    rx = iota
    gx
    bx
)

func newQuantizer(img image.Image, nq int) *quantizer {
    b := img.Bounds()
    npx := (b.Max.X - b.Min.X) * (b.Max.Y - b.Min.Y)
    // Create work space.
    qz := &quantizer{
        img: img,
        ch:  make(chValues, npx),
        cs:  make([]cluster, nq),
    }
    // Populate initial cluster with all pixels from image.
    c := &qz.cs[0]
    px := make([]point, npx)
    c.px = px
    i := 0
    for y := b.Min.Y; y < b.Max.Y; y++ {
        for x := b.Min.X; x < b.Max.X; x++ {
            px[i].x = x
            px[i].y = y
            i++
        }
    }
    return qz
}

func (qz *quantizer) cluster() {
    // Cluster by repeatedly splitting clusters.
    // Use a heap as priority queue for picking clusters to split.
    // The rule will be to spilt the cluster with the most pixels.
    // Terminate when the desired number of clusters has been populated
    // or when clusters cannot be further split.
    pq := new(queue)
    // Initial cluster.  populated at this point, but not analyzed.
    c := &qz.cs[0]
    for i := 1; ; {
        qz.setColorRange(c)
        // Cluster cannot be split if all pixels are the same color.
        // Only enqueue clusters that can be split.
        if c.chRange > 0 {
            heap.Push(pq, c) // add new cluster to queue
        }
        // If no clusters have any color variation, mark the end of the
        // cluster list and quit early.
        if len(*pq) == 0 {
            qz.cs = qz.cs[:i]
            break
        }
        s := heap.Pop(pq).(*cluster) // get cluster to split
        c = &qz.cs[i]                // set c to new cluster
        i++
        m := qz.Median(s)
        qz.Split(s, c, m) // split s into c and s
        // If that was the last cluster, we're done.
        if i == len(qz.cs) {
            break
        }
        qz.setColorRange(s)
        if s.chRange > 0 {
            heap.Push(pq, s) // return to queue
        }
    }
}

func (q *quantizer) setColorRange(c *cluster) {
    // Find extents of color values in each channel.
    var maxR, maxG, maxB uint32
    minR := uint32(math.MaxUint32)
    minG := uint32(math.MaxUint32)
    minB := uint32(math.MaxUint32)
    for _, p := range c.px {
        r, g, b, _ := q.img.At(p.x, p.y).RGBA()
        if r < minR {
            minR = r
        }
        if r > maxR {
            maxR = r
        }
        if g < minG {
            minG = g
        }
        if g > maxG {
            maxG = g
        }
        if b < minB {
            minB = b
        }
        if b > maxB {
            maxB = b
        }
    }
    // See which channel had the widest range.
    s := gx
    min := minG
    max := maxG
    if maxR-minR > max-min {
        s = rx
        min = minR
        max = maxR
    }
    if maxB-minB > max-min {
        s = bx
        min = minB
        max = maxB
    }
    c.widestCh = s
    c.chRange = max - min // also store the range of that channel
}

func (q *quantizer) Median(c *cluster) uint32 {
    px := c.px
    ch := q.ch[:len(px)]
    // Copy values from appropriate channel to buffer for computing median.
    switch c.widestCh {
    case rx:
        for i, p := range c.px {
            ch[i], _, _, _ = q.img.At(p.x, p.y).RGBA()
        }
    case gx:
        for i, p := range c.px {
            _, ch[i], _, _ = q.img.At(p.x, p.y).RGBA()
        }
    case bx:
        for i, p := range c.px {
            _, _, ch[i], _ = q.img.At(p.x, p.y).RGBA()
        }
    }
    // Median algorithm.
    sort.Sort(ch)
    half := len(ch) / 2
    m := ch[half]
    if len(ch)%2 == 0 {
        m = (m + ch[half-1]) / 2
    }
    return m
}

func (q *quantizer) Split(s, c *cluster, m uint32) {
    px := s.px
    var v uint32
    i := 0
    lt := 0
    gt := len(px) - 1
    eq := q.eq[:0] // reuse any existing buffer
    for i <= gt {
        // Get pixel value of appropriate channel.
        r, g, b, _ := q.img.At(px[i].x, px[i].y).RGBA()
        switch s.widestCh {
        case rx:
            v = r
        case gx:
            v = g
        case bx:
            v = b
        }
        // Categorize each pixel as either <, >, or == median.
        switch {
        case v < m:
            px[lt] = px[i]
            lt++
            i++
        case v > m:
            px[gt], px[i] = px[i], px[gt]
            gt--
        default:
            eq = append(eq, px[i])
            i++
        }
    }
    // Handle values equal to the median.
    if len(eq) > 0 {
        copy(px[lt:], eq) // move them back between the lt and gt values.
        // Then, if the number of gt values is < the number of lt values,
        // fix up i so that the split will include the eq values with
        // the gt values.
        if len(px)-i < lt {
            i = lt
        }
        q.eq = eq // squirrel away (possibly expanded) buffer for reuse
    }
    // Split the pixel list.
    s.px = px[:i]
    c.px = px[i:]
}

func (qz *quantizer) Paletted() *image.Paletted {
    cp := make(color.Palette, len(qz.cs))
    pi := image.NewPaletted(qz.img.Bounds(), cp)
    for i := range qz.cs {
        px := qz.cs[i].px
        // Average values in cluster to get palette color.
        var rsum, gsum, bsum int64
        for _, p := range px {
            r, g, b, _ := qz.img.At(p.x, p.y).RGBA()
            rsum += int64(r)
            gsum += int64(g)
            bsum += int64(b)
        }
        n64 := int64(len(px))
        cp[i] = color.NRGBA64{
            uint16(rsum / n64),
            uint16(gsum / n64),
            uint16(bsum / n64),
            0xffff,
        }
        // set image pixels
        for _, p := range px {
            pi.SetColorIndex(p.x, p.y, uint8(i))
        }
    }
    return pi
}

// Implement sort.Interface for sort in median algorithm.
func (c chValues) Len() int           { return len(c) }
func (c chValues) Less(i, j int) bool { return c[i] < c[j] }
func (c chValues) Swap(i, j int)      { c[i], c[j] = c[j], c[i] }

// Implement heap.Interface for priority queue of clusters.
func (q queue) Len() int { return len(q) }

// Less implements rule to select cluster with greatest number of pixels.
func (q queue) Less(i, j int) bool {
    return len(q[j].px) < len(q[i].px)
}

func (q queue) Swap(i, j int) {
    q[i], q[j] = q[j], q[i]
}
func (pq *queue) Push(x interface{}) {
    c := x.(*cluster)
    *pq = append(*pq, c)
}
func (pq *queue) Pop() interface{} {
    q := *pq
    n := len(q) - 1
    c := q[n]
    *pq = q[:n]
    return c
}


enum Token_type
    tk_EOI
    tk_Mul
    tk_Div
    tk_Mod
    tk_Add
    tk_Sub
    tk_Negate
    tk_Not
    tk_Lss
    tk_Leq
    tk_Gtr
    tk_Geq
    tk_Eq
    tk_Neq
    tk_Assign
    tk_And
    tk_Or
    tk_If
    tk_Else
    tk_While
    tk_Print
    tk_Putc
    tk_Lparen
    tk_Rparen
    tk_Lbrace
    tk_Rbrace
    tk_Semi
    tk_Comma
    tk_Ident
    tk_Integer
    tk_String
end enum

const NewLine     = chr(10)
const DoubleQuote = chr(34)
const BackSlash   = chr(92)

' where we store keywords and variables
type Symbol
    s_name as string
    tok as Token_type
end type

dim shared symtab() as Symbol

dim shared cur_line as string
dim shared cur_ch as string
dim shared line_num as integer
dim shared col_num as integer

function is_digit(byval ch as string) as long
    is_digit = ch >= "0" AndAlso ch <= "9"
end function

function is_alnum(byval ch as string) as long
    is_alnum = (ucase(ch) >= "A" AndAlso ucase(ch) <= "Z") OrElse is_digit(ch)
end function

sub error_msg(byval eline as integer, byval ecol as integer, byval msg as string)
    print "("; eline; ":"; ecol; ") "; msg
    print : print "Hit any to end program"
    sleep
    system
end sub

' add an identifier to the symbol table
function install(byval s_name as string, byval tok as Token_type) as integer
    dim n as integer = ubound(symtab) + 1
    redim preserve symtab(n)

    symtab(n).s_name = s_name
    symtab(n).tok    = tok
    return n
end function

' search for an identifier in the symbol table
function lookup(byval s_name as string) as integer
    dim i as integer

    for i = lbound(symtab) to ubound(symtab)
        if symtab(i).s_name = s_name then return i
    next
    return -1
end function

sub next_line()         ' read the next line of input from the source file
    cur_line = ""
    cur_ch  = ""        ' empty cur_ch means end-of-file
    if eof(1) then exit sub
    line input #1, cur_line
    cur_line = cur_line + NewLine
    line_num += + 1
    col_num = 1
end sub

sub next_char()         ' get the next char
    cur_ch = ""
    col_num += 1
    if col_num > len(cur_line) then next_line()
    if col_num <= len(cur_line) then cur_ch = mid(cur_line, col_num, 1)
end sub

function follow(byval err_line as integer, byval err_col as integer, byval expect as string, byval ifyes as Token_type, byval ifno as Token_type) as Token_type
    if cur_ch = expect then
        next_char()
        return ifyes
    end if
    if ifno = tk_eoi then error_msg(err_line, err_col, "follow unrecognized character: " + cur_ch)
    return ifno
end function

sub gettok(byref err_line as integer, byref err_col as integer, byref tok as Token_type, byref v as string)
    ' skip whitespace
    do while (cur_ch = " " or cur_ch = chr(9) or cur_ch = NewLine) and (cur_ch <> "")
        next_char()
    loop

    err_line = line_num
    err_col  = col_num

    select case cur_ch
        case "":  tok = tk_eoi: exit sub
        case "{": tok = tk_lbrace: next_char(): exit sub
        case "}": tok = tk_rbrace: next_char(): exit sub
        case "(": tok = tk_lparen: next_char(): exit sub
        case ")": tok = tk_rparen: next_char(): exit sub
        case "+": tok = tk_add:    next_char(): exit sub
        case "-": tok = tk_sub:    next_char(): exit sub
        case "*": tok = tk_mul:    next_char(): exit sub
        case "%": tok = tk_Mod:    next_char(): exit sub
        case ";": tok = tk_semi:   next_char(): exit sub
        case ",": tok = tk_comma:  next_char(): exit sub
        case "/": ' div or comment
            next_char()
            if cur_ch <> "*" then
                tok = tk_div
                exit sub
            end if
            ' skip comments
            next_char()
            do
                if cur_ch = "*" then
                    next_char()
                    if cur_ch = "/" then
                        next_char()
                        gettok(err_line, err_col, tok, v)
                        exit sub
                    end if
                elseif cur_ch = "" then error_msg(err_line, err_col, "EOF in comment")
                else
                    next_char()
                end if
            loop
        case "'":   ' single char literals
            next_char()
            v = str(asc(cur_ch))
            if cur_ch = "'" then error_msg(err_line, err_col, "empty character constant")
            if cur_ch = BackSlash then
                next_char()
                if cur_ch = "n" then
                    v = "10"
                elseif cur_ch = BackSlash then
                    v = "92"
                else error_msg(err_line, err_col, "unknown escape sequence: " + cur_ch)
                end if
            end if
            next_char()
            if cur_ch <> "'" then error_msg(err_line, err_col, "multi-character constant")
            next_char()
            tok = tk_integer
            exit sub
        case "<": next_char(): tok = follow(err_line, err_col, "=", tk_Leq, tk_Lss): exit sub
        case ">": next_char(): tok = follow(err_line, err_col, "=", tk_Geq, tk_Gtr): exit sub
        case "!": next_char(): tok = follow(err_line, err_col, "=", tk_Neq, tk_Not): exit sub
        case "=": next_char(): tok = follow(err_line, err_col, "=", tk_Eq,  tk_Assign): exit sub
        case "&": next_char(): tok = follow(err_line, err_col, "&", tk_And, tk_EOI): exit sub
        case "|": next_char(): tok = follow(err_line, err_col, "|", tk_Or,  tk_EOI): exit sub
        case DoubleQuote: ' string
            v = cur_ch
            next_char()
            do while cur_ch <> DoubleQuote
                if cur_ch = NewLine then error_msg(err_line, err_col, "EOL in string")
                if cur_ch = "" then error_msg(err_line, err_col, "EOF in string")
                v += cur_ch
                next_char()
            loop
            v += cur_ch
            next_char()
            tok = tk_string
            exit sub
        case else   ' integers or identifiers
            dim is_number as boolean = is_digit(cur_ch)
            v = ""
            do while is_alnum(cur_ch) orelse cur_ch = "_"
                if not is_digit(cur_ch) then is_number = false
                v += cur_ch
                next_char()
            loop
            if len(v) = 0 then error_msg(err_line, err_col, "unknown character: " + cur_ch)
            if is_digit(mid(v, 1, 1)) then
                if not is_number then error_msg(err_line, err_col, "invalid number: " + v)
                tok = tk_integer
                exit sub
            end if
            dim as integer index = lookup(v)
            if index = -1 then
                tok = tk_ident
            else
                tok = symtab(index).tok
            end if
            exit sub
    end select
end sub

sub init_lex(byval filein as string)
    install("else",  tk_else)
    install("if",    tk_if)
    install("print", tk_print)
    install("putc",  tk_putc)
    install("while", tk_while)

    open filein for input as #1

    cur_line = ""
    line_num = 0
    col_num = 0
    next_char()
end sub

sub scanner()
    dim err_line as integer
    dim err_col as integer
    dim tok as Token_type
    dim v as string
    dim tok_list(tk_eoi to tk_string) as string

    tok_list(tk_EOI    ) = "End_of_input"
    tok_list(tk_Mul    ) = "Op_multiply"
    tok_list(tk_Div    ) = "Op_divide"
    tok_list(tk_Mod    ) = "Op_mod"
    tok_list(tk_Add    ) = "Op_add"
    tok_list(tk_Sub    ) = "Op_subtract"
    tok_list(tk_Negate ) = "Op_negate"
    tok_list(tk_Not    ) = "Op_not"
    tok_list(tk_Lss    ) = "Op_less"
    tok_list(tk_Leq    ) = "Op_lessequal"
    tok_list(tk_Gtr    ) = "Op_greater"
    tok_list(tk_Geq    ) = "Op_greaterequal"
    tok_list(tk_Eq     ) = "Op_equal"
    tok_list(tk_Neq    ) = "Op_notequal"
    tok_list(tk_Assign ) = "Op_assign"
    tok_list(tk_And    ) = "Op_and"
    tok_list(tk_Or     ) = "Op_or"
    tok_list(tk_If     ) = "Keyword_if"
    tok_list(tk_Else   ) = "Keyword_else"
    tok_list(tk_While  ) = "Keyword_while"
    tok_list(tk_Print  ) = "Keyword_print"
    tok_list(tk_Putc   ) = "Keyword_putc"
    tok_list(tk_Lparen ) = "LeftParen"
    tok_list(tk_Rparen ) = "RightParen"
    tok_list(tk_Lbrace ) = "LeftBrace"
    tok_list(tk_Rbrace ) = "RightBrace"
    tok_list(tk_Semi   ) = "Semicolon"
    tok_list(tk_Comma  ) = "Comma"
    tok_list(tk_Ident  ) = "Identifier"
    tok_list(tk_Integer) = "Integer"
    tok_list(tk_String ) = "String"

    do
        gettok(err_line, err_col, tok, v)
        print using "#####  ##### \               " + BackSlash; err_line; err_col; tok_list(tok);
        if tok = tk_integer orelse tok = tk_ident orelse tok = tk_string then print " " + v;
        print
    loop until tok = tk_eoi
end sub

sub main()
    if command(1) = "" then print "filename required" : exit sub
    init_lex(command(1))
    scanner()
end sub

main()
print : print "Hit any to end program"
sleep
system


import qualified Data.ByteString.Lazy as BS
import qualified Data.Foldable as Fold
import qualified Data.List as List
import Data.Ord
import qualified Data.Sequence as Seq
import Data.Word
import System.Environment

import Codec.Picture
import Codec.Picture.Types

type Accessor = PixelRGB8 -> Pixel8

-- Getters for pixel components, as the constructor does not
-- provide any public ones.
red, blue, green :: Accessor
red   (PixelRGB8 r _ _) = r
green (PixelRGB8 _ g _) = g
blue  (PixelRGB8 _ _ b) = b

-- Get all of the pixels in the image in list form.
getPixels :: Pixel a => Image a -> [a]
getPixels image =
  [pixelAt image x y
  | x <- [0..(imageWidth image - 1)]
  , y <- [0..(imageHeight image - 1)]]

-- Compute the color-space extents of a list of pixels.
extents :: [PixelRGB8] -> (PixelRGB8, PixelRGB8)
extents pixels = (extent minimum, extent maximum)
  where
    bound f g = f $ map g pixels
    extent f  = PixelRGB8 (bound f red) (bound f green) (bound f blue)

-- Compute the average value of a list of pixels.
average :: [PixelRGB8] -> PixelRGB8
average pixels = PixelRGB8 (avg red) (avg green) (avg blue)
  where
    len   = toInteger $ length pixels
    avg c = fromIntegral $ (sum $ map (toInteger . c) pixels) `div` len

-- Perform a componentwise pixel operation.
compwise :: (Word8 -> Word8 -> Word8) -> PixelRGB8 -> PixelRGB8 -> PixelRGB8
compwise f (PixelRGB8 ra ga ba) (PixelRGB8 rb gb bb) =
  PixelRGB8 (f ra rb) (f ga gb) (f ba bb)

-- Compute the absolute difference of two pixels.
diffPixel :: PixelRGB8 -> PixelRGB8 -> PixelRGB8
diffPixel = compwise (\x y -> max x y - min x y)

-- Compute the Euclidean distance squared between two pixels.
distPixel :: PixelRGB8 -> PixelRGB8 -> Integer
distPixel x y = (rr ^ 2) + (gg ^ 2) + (bb ^ 2)
  where
    PixelRGB8 r g b = diffPixel x y
    rr              = toInteger r
    gg              = toInteger g
    bb              = toInteger b

-- Determine the dimension of the longest axis of the extents.
longestAccessor :: (PixelRGB8, PixelRGB8) -> Accessor
longestAccessor (l, h) =
  snd $ Fold.maximumBy (comparing fst) $ zip [r, g, b] [red, green, blue]
  where
    PixelRGB8 r g b = diffPixel h l

-- Find the index of a pixel to its respective palette.
nearestIdx :: PixelRGB8 -> [PixelRGB8] -> Int
nearestIdx pixel px = ans
  where
    Just ans = List.findIndex (== near) px
    near     = List.foldl1 comp px
    comp a b = if distPixel a pixel <= distPixel b pixel then a else b

-- Sort a list of pixels on its longest axis and then split by the mean.
-- It is intentional that the mean is chosen by all dimensions
-- instead of the given one.
meanSplit :: [PixelRGB8] -> Accessor -> ([PixelRGB8], [PixelRGB8])
meanSplit l f = List.splitAt index sorted
  where
    sorted = List.sortBy (comparing f) l
    index  = nearestIdx (average l) sorted

-- Perform the Median Cut algorithm on an image producing
-- an index map image and its respective palette.
meanCutQuant :: Image PixelRGB8 -> Int -> (Image Pixel8, Palette)
meanCutQuant image numRegions = (indexmap, palette)
  where
    extentsP p   = (p, extents p)
    regions      = map (\(p, e) -> (average p, e))
                   $ search $ Seq.singleton $ extentsP $ getPixels image
    palette      = snd $ generateFoldImage (\(x:xs) _ _ -> (xs, x))
                   (map fst regions) numRegions 1
    indexmap     = pixelMap
                   (\pixel -> fromIntegral $ nearestIdx pixel $ map fst regions)
                   image
    search queue =
      case Seq.viewl queue of
        (pixels, extent) Seq.:< queueB ->
          let (left, right) = meanSplit pixels $ longestAccessor extent
              queueC        = Fold.foldl (Seq.|>) queueB $ map extentsP [left, right]
          in if Seq.length queueC >= numRegions
             then List.take numRegions $ Fold.toList queueC
             else search queueC
        Seq.EmptyL                     -> error "Queue should never be empty."

quantizeIO :: FilePath -> FilePath -> Int -> IO ()
quantizeIO path outpath numRegions = do
  dynimage <- readImage path
  case dynimage of
    Left err                 -> putStrLn err
    Right (ImageRGB8 image)  -> doImage image
    Right (ImageRGBA8 image) -> doImage (pixelMap dropTransparency image)
    _                        -> putStrLn "Expecting RGB8 or RGBA8 image"
  where
    doImage image = do
      let (indexmap, palette) = meanCutQuant image numRegions
      case encodePalettedPng palette indexmap of
        Left err      -> putStrLn err
        Right bstring -> BS.writeFile outpath bstring

main :: IO ()
main = do
  args <- getArgs
  prog <- getProgName
  case args of
    [path, outpath] -> quantizeIO path outpath 16
    _               -> putStrLn $ "Usage: " ++ prog ++ " <image-file> <out-file.png>"


package main

import (
    "bufio"
    "fmt"
    "log"
    "os"
)

type TokenType int

const (
    tkEOI TokenType = iota
    tkMul
    tkDiv
    tkMod
    tkAdd
    tkSub
    tkNegate
    tkNot
    tkLss
    tkLeq
    tkGtr
    tkGeq
    tkEq
    tkNeq
    tkAssign
    tkAnd
    tkOr
    tkIf
    tkElse
    tkWhile
    tkPrint
    tkPutc
    tkLparen
    tkRparen
    tkLbrace
    tkRbrace
    tkSemi
    tkComma
    tkIdent
    tkInteger
    tkString
)

type Symbol struct {
    name string
    tok  TokenType
}

// symbol table
var symtab []Symbol

var scanner *bufio.Scanner

var (
    curLine = ""
    curCh   byte
    lineNum = 0
    colNum  = 0
)

const etx byte = 4 // used to signify EOI

func isDigit(ch byte) bool {
    return ch >= '0' && ch <= '9'
}

func isAlnum(ch byte) bool {
    return (ch >= 'a' && ch <= 'z') || (ch >= 'A' && ch <= 'Z') || isDigit(ch)
}

func errorMsg(eline, ecol int, msg string) {
    log.Fatalf("(%d:%d) %s", eline, ecol, msg)
}

// add an identifier to the symbol table
func install(name string, tok TokenType) {
    sym := Symbol{name, tok}
    symtab = append(symtab, sym)
}

// search for an identifier in the symbol table
func lookup(name string) int {
    for i := 0; i < len(symtab); i++ {
        if symtab[i].name == name {
            return i
        }
    }
    return -1
}

// read the next line of input from the source file
func nextLine() {
    if scanner.Scan() {
        curLine = scanner.Text()
        lineNum++
        colNum = 0
        if curLine == "" { // skip blank lines
            nextLine()
        }
    } else {
        err := scanner.Err()
        if err == nil { // EOF
            curCh = etx
            curLine = ""
            lineNum++
            colNum = 1
        } else {
            log.Fatal(err)
        }
    }
}

// get the next char
func nextChar() {
    if colNum >= len(curLine) {
        nextLine()
    }
    if colNum < len(curLine) {
        curCh = curLine[colNum]
        colNum++
    }
}

func follow(eline, ecol int, expect byte, ifyes, ifno TokenType) TokenType {
    if curCh == expect {
        nextChar()
        return ifyes
    }
    if ifno == tkEOI {
        errorMsg(eline, ecol, "follow unrecognized character: "+string(curCh))
    }
    return ifno
}

func gettok() (eline, ecol int, tok TokenType, v string) {
    // skip whitespace
    for curCh == ' ' || curCh == '\t' || curCh == '\n' {
        nextChar()
    }
    eline = lineNum
    ecol = colNum
    switch curCh {
    case etx:
        tok = tkEOI
        return
    case '{':
        tok = tkLbrace
        nextChar()
        return
    case '}':
        tok = tkRbrace
        nextChar()
        return
    case '(':
        tok = tkLparen
        nextChar()
        return
    case ')':
        tok = tkRparen
        nextChar()
        return
    case '+':
        tok = tkAdd
        nextChar()
        return
    case '-':
        tok = tkSub
        nextChar()
        return
    case '*':
        tok = tkMul
        nextChar()
        return
    case '%':
        tok = tkMod
        nextChar()
        return
    case ';':
        tok = tkSemi
        nextChar()
        return
    case ',':
        tok = tkComma
        nextChar()
        return
    case '/': // div or comment
        nextChar()
        if curCh != '*' {
            tok = tkDiv
            return
        }
        // skip comments
        nextChar()
        for {
            if curCh == '*' {
                nextChar()
                if curCh == '/' {
                    nextChar()
                    eline, ecol, tok, v = gettok()
                    return
                }
            } else if curCh == etx {
                errorMsg(eline, ecol, "EOF in comment")
            } else {
                nextChar()
            }
        }
    case '\'': // single char literals
        nextChar()
        v = fmt.Sprintf("%d", curCh)
        if curCh == '\'' {
            errorMsg(eline, ecol, "Empty character constant")
        }
        if curCh == '\\' {
            nextChar()
            if curCh == 'n' {
                v = "10"
            } else if curCh == '\\' {
                v = "92"
            } else {
                errorMsg(eline, ecol, "unknown escape sequence: "+string(curCh))
            }
        }
        nextChar()
        if curCh != '\'' {
            errorMsg(eline, ecol, "multi-character constant")
        }
        nextChar()
        tok = tkInteger
        return
    case '<':
        nextChar()
        tok = follow(eline, ecol, '=', tkLeq, tkLss)
        return
    case '>':
        nextChar()
        tok = follow(eline, ecol, '=', tkGeq, tkGtr)
        return
    case '!':
        nextChar()
        tok = follow(eline, ecol, '=', tkNeq, tkNot)
        return
    case '=':
        nextChar()
        tok = follow(eline, ecol, '=', tkEq, tkAssign)
        return
    case '&':
        nextChar()
        tok = follow(eline, ecol, '&', tkAnd, tkEOI)
        return
    case '|':
        nextChar()
        tok = follow(eline, ecol, '|', tkOr, tkEOI)
        return
    case '"': // string
        v = string(curCh)
        nextChar()
        for curCh != '"' {
            if curCh == '\n' {
                errorMsg(eline, ecol, "EOL in string")
            }
            if curCh == etx {
                errorMsg(eline, ecol, "EOF in string")
            }
            v += string(curCh)
            nextChar()
        }
        v += string(curCh)
        nextChar()
        tok = tkString
        return
    default: // integers or identifiers
        isNumber := isDigit(curCh)
        v = ""
        for isAlnum(curCh) || curCh == '_' {
            if !isDigit(curCh) {
                isNumber = false
            }
            v += string(curCh)
            nextChar()
        }
        if len(v) == 0 {
            errorMsg(eline, ecol, "unknown character: "+string(curCh))
        }
        if isDigit(v[0]) {
            if !isNumber {
                errorMsg(eline, ecol, "invalid number: "+string(curCh))
            }
            tok = tkInteger
            return
        }
        index := lookup(v)
        if index == -1 {
            tok = tkIdent
        } else {
            tok = symtab[index].tok
        }
        return
    }
}

func initLex() {
    install("else", tkElse)
    install("if", tkIf)
    install("print", tkPrint)
    install("putc", tkPutc)
    install("while", tkWhile)
    nextChar()
}

func process() {
    tokMap := make(map[TokenType]string)
    tokMap[tkEOI] = "End_of_input"
    tokMap[tkMul] = "Op_multiply"
    tokMap[tkDiv] = "Op_divide"
    tokMap[tkMod] = "Op_mod"
    tokMap[tkAdd] = "Op_add"
    tokMap[tkSub] = "Op_subtract"
    tokMap[tkNegate] = "Op_negate"
    tokMap[tkNot] = "Op_not"
    tokMap[tkLss] = "Op_less"
    tokMap[tkLeq] = "Op_lessequal"
    tokMap[tkGtr] = "Op_greater"
    tokMap[tkGeq] = "Op_greaterequal"
    tokMap[tkEq] = "Op_equal"
    tokMap[tkNeq] = "Op_notequal"
    tokMap[tkAssign] = "Op_assign"
    tokMap[tkAnd] = "Op_and"
    tokMap[tkOr] = "Op_or"
    tokMap[tkIf] = "Keyword_if"
    tokMap[tkElse] = "Keyword_else"
    tokMap[tkWhile] = "Keyword_while"
    tokMap[tkPrint] = "Keyword_print"
    tokMap[tkPutc] = "Keyword_putc"
    tokMap[tkLparen] = "LeftParen"
    tokMap[tkRparen] = "RightParen"
    tokMap[tkLbrace] = "LeftBrace"
    tokMap[tkRbrace] = "RightBrace"
    tokMap[tkSemi] = "Semicolon"
    tokMap[tkComma] = "Comma"
    tokMap[tkIdent] = "Identifier"
    tokMap[tkInteger] = "Integer"
    tokMap[tkString] = "String"

    for {
        eline, ecol, tok, v := gettok()
        fmt.Printf("%5d  %5d %-16s", eline, ecol, tokMap[tok])
        if tok == tkInteger || tok == tkIdent || tok == tkString {
            fmt.Println(v)
        } else {
            fmt.Println()
        }
        if tok == tkEOI {
            return
        }
    }
}

func check(err error) {
    if err != nil {
        log.Fatal(err)
    }
}

func main() {
    if len(os.Args) < 2 {
        fmt.Println("Filename required")
        return
    }
    f, err := os.Open(os.Args[1])
    check(err)
    defer f.Close()
    scanner = bufio.NewScanner(f)
    initLex()
    process()
}


kmcL=:4 :0
  C=. /:~ 256 #.inv ,y  NB. colors
  G=. x ([email protected]] <[email protected]* %) #C  NB. groups (initial)
  Q=. _  NB. quantized list of colors (initial
  whilst.-. Q-:&<.&(x&*)Q0 do.
    Q0=. Q
    Q=. /:~C (+/ % #)/.~ G
    G=. (i. <./)"1 C +/&.:*: .- |:Q
  end.Q
)


const execstring =`convert Quantum_frog.png -dither None -colors 16 Quantum_frog_new.png`
run(execstring)


// Version 1.2.41

import java.io.BufferedReader
import java.io.InputStreamReader

fun main(args: Array<String>) {
    // convert 'frog' to an image which uses only 16 colors, no dithering
    val pb = ProcessBuilder(
        "convert",
        "Quantum_frog.png",
        "-dither",
        "None",
        "-colors",
        "16",
        "Quantum_frog_16.png"
    )
    pb.directory(null)
    val proc = pb.start()
    proc.waitFor()

    // now show the colors used
    val pb2 = ProcessBuilder(
       "convert",
       "Quantum_frog_16.png",
       "-format",
       "%c",
       "-depth",
       "8",
       "histogram:info:-"
    )
    pb2.directory(null)
    pb.redirectOutput(ProcessBuilder.Redirect.PIPE)
    val proc2 = pb2.start()
    val br = BufferedReader(InputStreamReader(proc2.inputStream))
    var clrNum = 0
    while (true) {
        val line = br.readLine() ?: break
        System.out.printf("%2d->%s\n", clrNum++, line)
    }
    br.close()
}


import Control.Applicative hiding (many, some)
import Control.Monad.State.Lazy
import Control.Monad.Trans.Maybe (MaybeT, runMaybeT)
import Data.Char (isAsciiLower, isAsciiUpper, isDigit, ord)
import Data.Foldable (asum)
import Data.Functor (($>))
import Data.Text (Text)
import qualified Data.Text as T
import Prelude hiding (lex)
import System.Environment (getArgs)
import System.IO
import Text.Printf

-- Tokens --------------------------------------------------------------------------------------------------------------
data Val = IntVal    Int            -- value
         | TextVal   String Text    -- name value
         | SymbolVal String         -- name
         | Skip
         | LexError  String         -- message

data Token = Token Val Int Int    -- value line column

instance Show Val where
    show (IntVal             value) = printf "%-18s%d\n" "Integer" value
    show (TextVal   "String" value) = printf "%-18s%s\n" "String" (show $ T.unpack value)    -- show escaped characters
    show (TextVal   name     value) = printf "%-18s%s\n" name (T.unpack value)
    show (SymbolVal name          ) = printf "%s\n"      name
    show (LexError  msg           ) = printf "%-18s%s\n" "Error" msg
    show Skip                       = printf ""

instance Show Token where
    show (Token val line column) = printf "%2d   %2d   %s" line column (show val)

printTokens :: [Token] -> String
printTokens tokens =
    "Location  Token name        Value\n"      ++
    "--------------------------------------\n" ++
    (concatMap show tokens)

-- Tokenizers ----------------------------------------------------------------------------------------------------------
makeToken :: Lexer Val -> Lexer Token
makeToken lexer = do
    (t, l, c) <- get
    val <- lexer

    case val of
        Skip -> nextToken

        LexError msg -> do
            (_, l', c') <- get

            let code = T.unpack $ T.take (c' - c + 1) t
            let str = printf "%s\n%s(%d, %d): %s" msg (replicate 27 ' ') l' c' code

            ch <- peek
            unless (ch == '\0') $ advance 1

            return $ Token (LexError str) l c

        _ -> return $ Token val l c

simpleToken :: String -> String -> Lexer Val
simpleToken lexeme name = lit lexeme $> SymbolVal name

makeTokenizers :: [(String, String)] -> Lexer Val
makeTokenizers = asum . map (uncurry simpleToken)

keywords :: Lexer Val
keywords = makeTokenizers
    [("if",    "Keyword_if"),    ("else", "Keyword_else"), ("while", "Keyword_while"),
     ("print", "Keyword_print"), ("putc", "Keyword_putc")]

operators :: Lexer Val
operators = makeTokenizers
    [("*", "Op_multiply"), ("/",  "Op_divide"),    ("%",  "Op_mod"),      ("+", "Op_add"),
     ("-", "Op_subtract"), ("<=", "Op_lessequal"), ("<",  "Op_less"),     (">=", "Op_greaterequal"),
     (">", "Op_greater"),  ("==", "Op_equal"),     ("!=", "Op_notequal"), ("!", "Op_not"),
     ("=", "Op_assign"),   ("&&", "Op_and"),       ("||", "Op_or")]

symbols :: Lexer Val
symbols = makeTokenizers
    [("(", "LeftParen"), (")", "RightParen"),
     ("{", "LeftBrace"), ("}", "RightBrace"),
     (";", "Semicolon"), (",", "Comma")]

isIdStart :: Char -> Bool
isIdStart ch = isAsciiLower ch || isAsciiUpper ch || ch == '_'

isIdEnd :: Char -> Bool
isIdEnd ch = isIdStart ch || isDigit ch

identifier :: Lexer Val
identifier = TextVal "Identifier" <$> lexeme
    where lexeme = T.cons <$> (one isIdStart) <*> (many isIdEnd)

integer :: Lexer Val
integer = do
    lexeme <- some isDigit
    next_ch <- peek

    if (isIdStart next_ch) then
        return $ LexError "Invalid number. Starts like a number, but ends in non-numeric characters."
    else do
        let num = read (T.unpack lexeme) :: Int
        return $ IntVal num

character :: Lexer Val
character = do
    lit "'"
    str <- lookahead 3

    case str of
        (ch : '\'' : _)    -> advance 2 $> IntVal (ord ch)
        "\\n'"             -> advance 3 $> IntVal 10
        "\\\\'"            -> advance 3 $> IntVal 92
        ('\\' : ch : "\'") -> advance 2 $> LexError (printf "Unknown escape sequence \\%c" ch)
        ('\'' : _)         -> return $ LexError "Empty character constant"
        _                  -> advance 2 $> LexError "Multi-character constant"

string :: Lexer Val
string = do
    lit "\""

    loop (T.pack "") =<< peek
        where loop t ch = case ch of
                  '\\' -> do
                      next_ch <- next

                      case next_ch of
                          'n'  -> loop (T.snoc t '\n') =<< next
                          '\\' -> loop (T.snoc t '\\') =<< next
                          _    -> return $ LexError $ printf "Unknown escape sequence \\%c" next_ch

                  '"' -> next $> TextVal "String" t

                  '\n' -> return $ LexError $ "End-of-line while scanning string literal." ++
                                              " Closing string character not found before end-of-line."

                  '\0' -> return $ LexError $ "End-of-file while scanning string literal." ++
                                              " Closing string character not found."

                  _    -> loop (T.snoc t ch) =<< next

skipComment :: Lexer Val
skipComment = do
    lit "/*"

    loop =<< peek
        where loop ch = case ch of
                  '\0' -> return $ LexError "End-of-file in comment. Closing comment characters not found."

                  '*'  -> do
                      next_ch <- next

                      case next_ch of
                          '/' -> next $> Skip
                          _   -> loop next_ch

                  _    -> loop =<< next

nextToken :: Lexer Token
nextToken = do
    skipWhitespace

    makeToken $ skipComment
            <|> keywords
            <|> identifier
            <|> integer
            <|> character
            <|> string
            <|> operators
            <|> symbols
            <|> simpleToken "\0" "End_of_input"
            <|> (return $ LexError "Unrecognized character.")

main :: IO ()
main = do
    args <- getArgs
    (hin, hout) <- getIOHandles args

    withHandles hin hout $ printTokens . (lex nextToken)

------------------------------------------------------------------------------------------------------------------------
-- Machinery
------------------------------------------------------------------------------------------------------------------------

-- File handling -------------------------------------------------------------------------------------------------------
getIOHandles :: [String] -> IO (Handle, Handle)
getIOHandles [] = return (stdin, stdout)

getIOHandles [infile] = do
    inhandle <- openFile infile ReadMode
    return (inhandle, stdout)

getIOHandles (infile : outfile : _) = do
    inhandle  <- openFile infile ReadMode
    outhandle <- openFile outfile WriteMode
    return (inhandle, outhandle)

withHandles :: Handle -> Handle -> (String -> String) -> IO ()
withHandles in_handle out_handle f = do
    contents <- hGetContents in_handle
    let contents' = contents ++ "\0"    -- adding \0 simplifies treatment of EOF

    hPutStr out_handle $ f contents'

    unless (in_handle == stdin) $ hClose in_handle
    unless (out_handle == stdout) $ hClose out_handle

-- Lexer ---------------------------------------------------------------------------------------------------------------
type LexerState = (Text, Int, Int)    -- input line column
type Lexer = MaybeT (State LexerState)

lexerAdvance :: Int -> LexerState -> LexerState
lexerAdvance 0 ctx = ctx

lexerAdvance 1 (t, l, c)
    | ch == '\n' = (rest, l + 1, 1    )
    | otherwise  = (rest, l,     c + 1)
    where
        (ch, rest) = (T.head t, T.tail t)

lexerAdvance n ctx = lexerAdvance (n - 1) $ lexerAdvance 1 ctx

advance :: Int -> Lexer ()
advance n = modify $ lexerAdvance n

peek :: Lexer Char
peek = gets $ \(t, _, _) -> T.head t

lookahead :: Int -> Lexer String
lookahead n = gets $ \(t, _, _) -> T.unpack $ T.take n t

next :: Lexer Char
next = advance 1 >> peek

skipWhitespace :: Lexer ()
skipWhitespace = do
    ch <- peek
    when (ch `elem` " \n") (next >> skipWhitespace)

lit :: String -> Lexer ()
lit lexeme = do
    (t, _, _) <- get
    guard $ T.isPrefixOf (T.pack lexeme) t
    advance $ length lexeme

one :: (Char -> Bool) -> Lexer Char
one f = do
    ch <- peek
    guard $ f ch
    next
    return ch

lexerMany :: (Char -> Bool) -> LexerState -> (Text, LexerState)
lexerMany f (t, l, c) = (lexeme, (t', l', c'))
    where (lexeme, _) = T.span f t
          (t', l', c') = lexerAdvance (T.length lexeme) (t, l, c)

many :: (Char -> Bool) -> Lexer Text
many f = state $ lexerMany f

some :: (Char -> Bool) -> Lexer Text
some f = T.cons <$> (one f) <*> (many f)

lex :: Lexer a -> String -> [a]
lex lexer str = loop lexer (T.pack str, 1, 1)
    where loop lexer s
              | T.null txt = [t]
              | otherwise  = t : loop lexer s'

              where (Just t, s') = runState (runMaybeT lexer) s
                    (txt, _, _) = s'


import algorithm
import nimPNG

type

  Channel {.pure.} = enum R, G, B

  QItem = tuple
    color: array[Channel, byte]   # Color of the pixel.
    index: int                    # Position of pixel in the sequential sequence.

#---------------------------------------------------------------------------------------------------

proc quantize(bucket: openArray[QItem]; output: var seq[byte]) =
  ## Apply the quantization to the pixels in the bucket.

  # Compute the mean value on each channel.
  var means: array[Channel, int]
  for qItem in bucket:
    for channel in R..B:
      means[channel] += qItem.color[channel].int
  for channel in R..B:
    means[channel] = (means[channel] / bucket.len).toInt

  # Store the new colors into the pixels.
  for qItem in bucket:
    for channel in R..B:
      output[3 * qItem.index + ord(channel)] = means[channel].byte

#---------------------------------------------------------------------------------------------------

proc medianCut(bucket: openArray[QItem]; depth: Natural; output: var seq[byte]) =
  ## Apply the algorithm on the bucket.

  if depth == 0:
    # Terminated for this bucket. Apply the quantization.
    quantize(bucket, output)
    return

  # Compute the range of values for each channel.
  var minVal: array[Channel, int] = [1000, 1000, 1000]
  var maxVal: array[Channel, int] = [-1, -1, -1]
  for qItem in bucket:
    for channel in R..B:
      let val = qItem.color[channel].int
      if val < minVal[channel]: minVal[channel] = val
      if val > maxVal[channel]: maxVal[channel] = val
  let valRange: array[Channel, int] = [maxVal[R] - minVal[R],
                                       maxVal[G] - minVal[G],
                                       maxVal[B] - minVal[B]]

  # Find the channel with the greatest range.
  var selchannel: Channel
  if valRange[R] >= valRange[G]:
    if valRange[R] >= valRange[B]:
      selchannel = R
    else:
      selchannel = B
  elif valrange[G] >= valrange[B]:
    selchannel = G
  else:
    selchannel = B

  # Sort the quantization items according to the selected channel.
  let sortedBucket = case selchannel
                     of R: sortedByIt(bucket, it.color[R])
                     of G: sortedByIt(bucket, it.color[G])
                     of B: sortedByIt(bucket, it.color[B])

  # Split the bucket into two buckets.
  let medianIndex = bucket.high div 2
  medianCut(sortedBucket.toOpenArray(0, medianIndex), depth - 1, output)
  medianCut(sortedBucket.toOpenArray(medianIndex, bucket.high), depth - 1, output)

#———————————————————————————————————————————————————————————————————————————————————————————————————

const Input = "Quantum_frog.png"
const Output = "Quantum_frog_16.png"

let pngImage = loadPNG24(seq[byte], Input).get()

# Build the first bucket.
var bucket = newSeq[QItem](pngImage.data.len div 3)
var idx: Natural = 0
for item in bucket.mitems:
  item = (color: [pngImage.data[idx], pngImage.data[idx + 1], pngImage.data[idx + 2]],
          index: idx div 3)
  inc idx, 3

# Create the storage for the quantized image.
var data = newSeq[byte](pngImage.data.len)

# Launch the quantization.
medianCut(bucket, 4, data)

# Save the result into a PNG file.
let status = savePNG24(Output, data, pngImage.width, pngImage.height)
if status.isOk:
  echo "File ", Input, " processed. Result is available in file ", Output
else:
  echo "Error: ", status.error


let rem_from rem from =
  List.filter ((<>) rem) from

let float_rgb (r,g,b) =  (* prevents int overflow *)
  (float r, float g, float b)

let round x =
  int_of_float (floor (x +. 0.5))

let int_rgb (r,g,b) =
  (round r, round g, round b)

let rgb_add (r1,g1,b1) (r2,g2,b2) =
  (r1 +. r2,
   g1 +. g2,
   b1 +. b2)

let rgb_mean px_list =
  let n = float (List.length px_list) in
  let r, g, b = List.fold_left rgb_add (0.0, 0.0, 0.0) px_list in
  (r /. n, g /. n, b /. n)

let extrems lst =
  let min_rgb = (infinity, infinity, infinity)
  and max_rgb = (neg_infinity, neg_infinity, neg_infinity) in
  List.fold_left (fun ((sr,sg,sb), (mr,mg,mb)) (r,g,b) ->
    ((min sr r), (min sg g), (min sb b)),
    ((max mr r), (max mg g), (max mb b))
  ) (min_rgb, max_rgb) lst

let volume_and_dims lst =
  let (sr,sg,sb), (br,bg,bb) = extrems lst in
  let dr, dg, db = (br -. sr), (bg -. sg), (bb -. sb) in
  (dr *. dg *. db),
  (dr, dg, db)

let make_cluster pixel_list =
  let vol, dims = volume_and_dims pixel_list in
  let len = float (List.length pixel_list) in
  (rgb_mean pixel_list, len *. vol, dims, pixel_list)

type axis = R | G | B
let largest_axis (r,g,b) =
  match compare r g, compare r b with
  | 1, 1 -> R
  | -1, 1 -> G
  | 1, -1 -> B
  | _ ->
      match compare g b with
      | 1 -> G
      | _ -> B

let subdivide ((mr,mg,mb), n_vol_prod, vol, pixels) =
  let part_func =
    match largest_axis vol with
    | R -> (fun (r,_,_) -> r < mr)
    | G -> (fun (_,g,_) -> g < mg)
    | B -> (fun (_,_,b) -> b < mb)
  in
  let px1, px2 = List.partition part_func pixels in
  (make_cluster px1, make_cluster px2)

let color_quant img n =
  let width, height = get_dims img in
  let clusters =
    let lst = ref [] in
    for x = 0 to pred width do
      for y = 0 to pred height do
        let rgb = float_rgb (get_pixel_unsafe img x y) in
        lst := rgb :: !lst
      done;
    done;
    ref [make_cluster !lst]
  in
  while (List.length !clusters) < n do
    let dumb = (0.0,0.0,0.0) in
    let unused = (dumb, neg_infinity, dumb, []) in
    let select ((_,v1,_,_) as c1) ((_,v2,_,_) as c2) =
      if v1 > v2 then c1 else c2
    in
    let cl = List.fold_left (fun c1 c2 -> select c1 c2) unused !clusters in
    let cl1, cl2 = subdivide cl in
    clusters := cl1 :: cl2 :: (rem_from cl !clusters)
  done;
  let module PxMap = Map.Make
    (struct type t = float * float * float let compare = compare end) in
  let m =
    List.fold_left (fun m (mean, _, _, pixel_list) ->
      let int_mean = int_rgb mean in
      List.fold_left (fun m px -> PxMap.add px int_mean m) m pixel_list
    ) PxMap.empty !clusters
  in
  let res = new_img ~width ~height in
  for y = 0 to pred height do
    for x = 0 to pred width do
      let rgb = float_rgb (get_pixel_unsafe img x y) in
      let mean_rgb = PxMap.find rgb m in
      put_pixel_unsafe res mean_rgb x y;
    done;
  done;
  (res)