Pannyx

Request #07

% cdp
~/devel/proto
% pp aej-qlist_for_array_of_subtype_of_int.adb aej-qlist_for_array_of_subtype_of_int.ads
with Ada.Text_IO;
with Aej.Daejana;
package body Aej.Qlist_For_Array_Of_Subtype_Of_Int is

use Ada; use Text_IO;
use Aej; use Daejana;

use type Int_T;

function New_Qlist (N : Enum_T) return Qlist_T is begin
      return new Qlist_St'(N, null, null); end New_Qlist;

procedure Enqueue (Q : Qlist_T; A : Array_T) is
   B : Qlist_Node_T; P : Qlist_Node_T;

begin
   P := new Qlist_Node_St'(Q.N, A, null);
   B := Q.Last;
   Q.Last := P;
   if B = null then
      Q.First := P;
   else
      B.Next := P;
   end if;
   return;

end Enqueue;

function Dequeue (Q : Qlist_T) return Array_T is
   B : Qlist_Node_T; P : Qlist_Node_T;

begin
   B := Q.First;
   if B = null then Ouch; return Array_T'(1 .. 0 => 0); end if;

   if B.Next = null then
      Q.Last := null;
   end if;
   Q.First := B.Next;
   return B.Item;

end Dequeue;

procedure Delete_Qlist (Q : in out Qlist_T) is begin if Q = null then Ouch; raise Constraint_Error; end if;
      declare A : Array_T(1 .. Q.N); begin while To_First(Q) /= null loop A := Dequeue(Q); end loop; end;
      Q := null; return; end Delete_Qlist;

procedure Delete_Perms (Q : in out Qlist_T) is begin
      Delete_Qlist(Q); return; end Delete_Perms;

function To_First (Q : Qlist_T) return Qlist_Node_T is begin
      return Q.First; end To_First;

procedure To_Next (P : in out Qlist_Node_T) is begin
      P := P.Next; return; end To_Next;

function Item (P : Qlist_Node_T) return Array_T is begin
      return P.Item; end Item;

end Aej.Qlist_For_Array_Of_Subtype_Of_Int;
with Ada.Text_IO;
with Aej.Daejana;
generic

   type Item_T is range <>;
   type Array_T is array (Index_T range <>) of Item_T;

package Aej.Qlist_For_Array_Of_Subtype_Of_Int is

use Ada; use Text_IO;
use Aej; use Daejana;

type Qlist_Node_St (N : Enum_T) is private;
type Qlist_Node_T is access all Qlist_Node_St;

type Qlist_St is private;
type Qlist_T is access all Qlist_St;

function New_Qlist (N : Enum_T) return Qlist_T;
procedure Delete_Qlist (Q : in out Qlist_T);

function To_First (Q : Qlist_T) return Qlist_Node_T;
procedure To_Next (P : in out Qlist_Node_T);
function Item (P : Qlist_Node_T) return Array_T;

procedure Enqueue (Q : Qlist_T; A : Array_T);
function Dequeue (Q : Qlist_T) return Array_T;

private

   type Qlist_Node_St (N : Enum_T) is record
      Item : Array_T(1 .. N);
      Next : Qlist_Node_T;
   end record;

   type Qlist_St is record
      N : Enum_T;
      First : Qlist_Node_T;
      Last : Qlist_Node_T;
   end record;

end Aej.Qlist_For_Array_Of_Subtype_Of_Int;
% pp aej-perms.adb aej-perms.ads
with Ada.Text_IO;
with Aej.Daejana;
with Aej.Qlist_For_Array_Of_Subtype_Of_Int;
package body Aej.Perms is

use Ada; use Text_IO;
use Aej; use Daejana;

use type Int_T;

use Qlist_Of_Int_Array;

function New_Perms (N : Enum_T) return Qlist_T is

   Q : Qlist_T;

   procedure Qadd (A : Array_T; B : Array_T) is

   begin
      if B'Length < 2 then Enqueue(Q, A & B); return; end if;

      for K in B'Range loop
         Qadd(A & Array_T'(1 => B(K)), B(B'First .. K - 1) & B(K + 1 .. B'Last));
      end loop;
      return;

   end Qadd;

   B : Array_T(1 .. N);

begin
   Q := New_Qlist(N);
   if N < 1 then return Q; end if;

   if N < 2 then Enqueue(Q, Array_T'(1 => 1)); return Q; end if;

   for K in B'Range loop B(K) := Item_T( K); end loop;
   Qadd(Array_T'(1 .. 0 => <>), B);
   return Q;

end New_Perms;

procedure Delete_Perms (Q : in out Qlist_T) is begin
      Delete_Qlist(Q); return; end Delete_Perms;

end Aej.Perms;
with Ada.Text_IO;
with Aej.Daejana;
with Aej.Qlist_For_Array_Of_Subtype_Of_Int;
generic

   type Item_T is range <>;
   type Array_T is array (Index_T range <>) of Item_T;

package Aej.Perms is

use Ada; use Text_IO;
use Aej; use Daejana;

package Qlist_Of_Int_Array is new Qlist_For_Array_Of_Subtype_Of_Int(Item_T, Array_T);

subtype Qlist_Node_St is Qlist_Of_Int_Array.Qlist_Node_St;
subtype Qlist_Node_T is Qlist_Of_Int_Array.Qlist_Node_T;

subtype Qlist_St is Qlist_Of_Int_Array.Qlist_St;
subtype Qlist_T is Qlist_Of_Int_Array.Qlist_T;

function New_Perms (N : Enum_T) return Qlist_T;
procedure Delete_Perms (Q : in out Qlist_T);

function To_First (Q : Qlist_T) return Qlist_Node_T renames Qlist_Of_Int_Array.To_First;
procedure To_Next (P : in out Qlist_Node_T) renames Qlist_Of_Int_Array.To_Next;
function Item (P : Qlist_Node_T) return Array_T renames Qlist_Of_Int_Array.Item;

function Dequeue (Q : Qlist_T) return Array_T renames Qlist_Of_Int_Array.Dequeue;

end Aej.Perms;
% cdm
~/devel/sleek
% pp perms_m.adb
with Ada.Characters.Handling;
with Ada.Command_Line;
with Ada.Exceptions;
with Ada.Text_IO;
with Aej.Daejana;
with Aej.Perms;
procedure Perms_M is

use Ada; use Text_IO;
use Aej; use Daejana;

use Int_IO;
use type Int_T;

function From_String (S : String) return Enum_T is
   J : Enum_T; N : Enum_T;

begin
   N := 0; J := 1;
   while J < S'Length + 1 loop
      exit when not Characters.Handling.Is_Digit(S(Integer( J)));

      N := N * 10 + Enum_T( Character'Pos(S(Integer( J)))) - 48;
      J := J + 1;
   end loop;

   return N;

end From_String;

type Int_Array_T is array (Index_T range <>) of Int_T;
package Pp is new Perms(Int_T, Int_Array_T); use Pp;

use type Qlist_Node_T;

Q : Qlist_T;
P : Qlist_Node_T;
J : Int_T;
N : Enum_T;

begin
   Command_Line.Set_Exit_Status(Command_Line.Success);
   New_Line;

   N := (if 0 < Command_Line.Argument_Count then From_String(Command_Line.Argument(1)) else 4);

   declare
      A : Int_Array_T(1 .. N);

   begin
      Q := New_Perms(N);

--    Put("("); New_Line;
--    P := To_First(Q);
--    while P /= null loop
--       Put("   [");
--       A := Item(P);
--       for K in A'Range loop
--          Put(A(K), Width => 2);
--       end loop;
--       Put(" ],"); New_Line;
--       To_Next(P);
--    end loop;
--    Put(");"); New_Line;
--    New_Line;

      Put("("); New_Line;
      while To_First(Q) /= null loop
         Put("   [");
         A := Dequeue(Q);
         for K in A'Range loop
            Put(A(K), Width => 2);
         end loop;
         Put(" ],"); New_Line;
      end loop;
      Put(");"); New_Line;

      Delete_Perms(Q);
   end;
   New_Line;
   return;

exception
   when E : others =>
      New_Line(Standard_Error);
      New_Line(Standard_Error);
      Put(Standard_Error, "** ");
      Put(Standard_Error, Exceptions.Exception_Name(E));
      Put(Standard_Error, "! (");
      Put(Standard_Error, Exceptions.Exception_Message(E));
      Put(Standard_Error, ")");
      New_Line(Standard_Error);
      New_Line;
      Command_Line.Set_Exit_Status(Command_Line.Failure);

end Perms_M;
% abr perms_m

(
   [ 1 2 3 4 ],
   [ 1 2 4 3 ],
   [ 1 3 2 4 ],
   [ 1 3 4 2 ],
   [ 1 4 2 3 ],
   [ 1 4 3 2 ],
   [ 2 1 3 4 ],
   [ 2 1 4 3 ],
   [ 2 3 1 4 ],
   [ 2 3 4 1 ],
   [ 2 4 1 3 ],
   [ 2 4 3 1 ],
   [ 3 1 2 4 ],
   [ 3 1 4 2 ],
   [ 3 2 1 4 ],
   [ 3 2 4 1 ],
   [ 3 4 1 2 ],
   [ 3 4 2 1 ],
   [ 4 1 2 3 ],
   [ 4 1 3 2 ],
   [ 4 2 1 3 ],
   [ 4 2 3 1 ],
   [ 4 3 1 2 ],
   [ 4 3 2 1 ],
);

% cda
~/devel/proto/aej
% pp qlist_int_chunk.c qlist_int_chunk.h
#define QLIST_INT_CHUNK_C
#include <qlist_int_chunk.h>

qlist_int_chunk_t new_qlist_int_chunk (int_t n) { qlist_int_chunk_t q;
      if (( q = malloc(sizeof(qlist_int_chunk_st))) == NULL) { ouch(); return NULL; }
      q->n_items = n; q->first = NULL; q->last = NULL; return q; }

void
delete_qlist_int_chunk (qlist_int_chunk_t * q)
{

   if (* q == NULL) { return; }

   while (!( qlist_int_chunk_to_first(* q) == NULL)) {
      qlist_int_chunk_dequeue(* q);
   }
   free(* q); * q = NULL;
   return;

}

qlist_int_chunk_node_t qlist_int_chunk_to_first (qlist_int_chunk_t q) {
      return q->first; }

qlist_int_chunk_node_t qlist_int_chunk_to_last (qlist_int_chunk_t q) {
      return q->last; }

qlist_int_chunk_node_t qlist_int_chunk_to_next (qlist_int_chunk_node_t p) {
      return p->next; }

int_t * qlist_int_chunk_access (qlist_int_chunk_node_t p) {
      return p->v; }

void
qlist_int_chunk_enqueue (qlist_int_chunk_t q, int_t * v)
{
   int_t k; qlist_int_chunk_node_t b; qlist_int_chunk_node_t p;

   if (( p = malloc(sizeof (qlist_int_chunk_node_st) + sizeof (int_t) * q->n_items)) == NULL) { ouch(); return; }

   p->next = NULL; if (!( v == NULL)) { k = 0; while (k < q->n_items) { p->v[k] = v[k]; k += 1; } }
   b = q->last;
   q->last = p;
   if (b == NULL) {
      q->first = p;
   }
   else {
      b->next = p;
   }
   return;

}

void
qlist_int_chunk_dequeue (qlist_int_chunk_t q)
{
   qlist_int_chunk_node_t b;

   b = q->first;
   if (b == NULL) { ouch(); return; }

   if (b->next == NULL) {
      q->last = NULL;
   }
   q->first = b->next;
   free(b);
   return;

}

// qlist_int_chunk.c
#ifndef QLIST_INT_CHUNK_H
#define QLIST_INT_CHUNK_H
#include <daejana.h>

struct qlist_int_chunk_node_struct;
typedef struct qlist_int_chunk_node_struct * qlist_int_chunk_node_t;
typedef struct qlist_int_chunk_node_struct {
   qlist_int_chunk_node_t next;
   int_t v [];
} qlist_int_chunk_node_st;

typedef struct qlist_int_chunk_struct {
   int_t n_items;
   qlist_int_chunk_node_t first;
   qlist_int_chunk_node_t last;
} qlist_int_chunk_st, * qlist_int_chunk_t;

#ifndef QLIST_INT_CHUNK_C
#endif

qlist_int_chunk_t new_qlist_int_chunk (int_t);
void delete_qlist_int_chunk (qlist_int_chunk_t *);

qlist_int_chunk_node_t qlist_int_chunk_to_first (qlist_int_chunk_t);
qlist_int_chunk_node_t qlist_int_chunk_to_last (qlist_int_chunk_t);
qlist_int_chunk_node_t qlist_int_chunk_to_next (qlist_int_chunk_node_t);
int_t * qlist_int_chunk_access (qlist_int_chunk_node_t);

void qlist_int_chunk_enqueue (qlist_int_chunk_t, int_t *);
void qlist_int_chunk_dequeue (qlist_int_chunk_t);

#endif
// qlist_int_chunk.h
% pp perms.c perms.h
#include <perms.h>

static void new_perms_aux (qlist_int_chunk_t, int_t, int_t *, int_t, int_t *, int_t *);


static void
new_perms_aux (qlist_int_chunk_t q, int_t m, int_t r [], int_t n, int_t s [], int_t * p)
{
   int_t j; int_t k; int_t l; int_t * v;

   if (n < 1) {
      qlist_int_chunk_enqueue(q, r);  // v[0..m-1] ← r[0..m-1]
      * p += 1;
      return;
   }
   {
      int_t a [m + 1];
      int_t b [n - 1];

      k = 0; while (k < m) { a[k] = r[k]; k += 1; }  // a[0..m-1] ← r[0..m-1]
      l = 0;
      while (l < n) {
         a[m] = s[l];  // a[m] ← s[l], l := 0..n-1
/*
         k = 0;
         j = 0;
         while (j < n) {
            if (!(a[m] == s[j])) {
               b[k] = s[j];  // b[k] ← t[j], k,j := 0..n-1, if not a[m] = s[j]
               k += 1;
            }
            j += 1;
         }
*/
         if (l < 1) {
            new_perms_aux(q, m + 1, a, n - 1, & s [1], p);
         }
         else if (l < n - 1) {
            memcpy(b, s, l * sizeof (int_t)); memcpy(& b [l], & s [l + 1], (n - 1 - l) * sizeof (int_t));
            new_perms_aux(q, m + 1, a, n - 1, b, p);
         }
         else {
            new_perms_aux(q, m + 1, a, n - 1, s, p);
         }
         l += 1;
      }
   }
   return;

}

void new_perms (int_t n, qlist_int_chunk_t * q, int_t * p)
{
   int_t k;

   if (n < 1) { * q = NULL; return; }

   * q = new_qlist_int_chunk(n);
   {
      int_t s [n];

      k = 0;
      while (k < n) {
         s[k] = k + 1;
         k += 1;
      }
      * p = 0;
      new_perms_aux(* q, 0, NULL, n, s, p);
   }
   return;

}

void
delete_perms (qlist_int_chunk_t * q) {
      delete_qlist_int_chunk(q);
      return; }

// perms.c
#ifndef PERMS_H
#define PERMS_H
#include <daejana.h>
#include <qlist_int_chunk.h>

#ifndef PERMS_C
#endif

void new_perms (int_t, qlist_int_chunk_t *, int_t *);
void delete_perms (qlist_int_chunk_t *);

#endif
// perms.h
% cds
~/devel/sleek
% pp perms_m.c
#include <chars.h>
#include <perms.h>


#define S_ITEMS "n_items"
#define N_PAD 8192
char s_pad [N_PAD];

static qlist_int_chunk_t q;
static qlist_int_chunk_node_t p;


int
main (int argc, char * argv [])
{
   int_t n_items; int_t k; char * s; char c;
   int_t * v;

   error_flag = false;
   printf("\n");
   if (argc < 2) {
      snprintf(s_pad, N_PAD, "%s : %s\x08", S_ITEMS, s_ellipsis); fputs(s_pad, stdout); fflush(stdout);
      while ((c = getchar()) == ' ' || c == '\t' || c == '\n') { if (c == '\n') { n_items = 0; fputs("\x1b[1A", stdout); goto L1; } }
      k = 0; while (!( c == '\n')) { s_pad[k] = c; c = getchar(); k += 1; } s_pad[k] = '\0';
      n_items = atoll(s_pad);
      fputs("\x1b[1A", stdout);
   }
   else {
      s = argv[1];
      k = 0; while ((c = s[k]) == ' ' || c == '\t') { k += 1; }
      if ('0' < c && c < '9' + 1) {
         n_items = atoll(&s[k]);
      }
      else if (c == '0') {
         if (s[k+1] == 'x' || s[k+1] == 'X') { n_items = strtoll(&s[k], NULL, 16); } else { n_items = 0; if (!( c == '\0' || c == ' ' || c ==
   ↪ '\t')) { ouch(); } }
      }
      else {
         n_items = 0; ouch();
      }
   }
L1:
   if (n_items == 0) { n_items = 4; }
   printf("%s %s %lld\n", S_ITEMS, s_left, n_items);
   printf("\n");

   printf("(\n");
   new_perms(n_items, &q, &k);
   if (!( q == NULL)) {
      while (!( ( p = qlist_int_chunk_to_first(q)) == NULL)) {
         v = qlist_int_chunk_access(p);
         printf("   [");
         k = 0;
         while (k < n_items) {
            printf(" %lld,", v[k]);
            k += 1;
         }
         printf(" ];\n");
         qlist_int_chunk_dequeue(q);
      }
      delete_perms(& q);
   }
   printf(")\n");

   printf("\n");
   if (error_flag) { exit(EXIT_FAILURE); }

   return EXIT_SUCCESS;

}

// perms_m.c
% cmk perms_m chars qlist_int_chunk perms
% ./perms_m 1

n_items ← 1

(
   [ 1, ];
)

% ./perms_m 2

n_items ← 2

(
   [ 1, 2, ];
   [ 2, 1, ];
)

% ./perms_m

n_items ← 3

(
   [ 1, 2, 3, ];
   [ 1, 3, 2, ];
   [ 2, 1, 3, ];
   [ 2, 3, 1, ];
   [ 3, 1, 2, ];
   [ 3, 2, 1, ];
)

% make clean
% pp perms_m.rkt
#lang racket/base

(require aej/daejana aej/qlist)

(define (perms n)
   (let (
         (q (make-qlist))
      )

      (define (aux s t)
         (let (
               (t-l (vector-length t))
            )
            (if… (< t-l 1) (then
               (ql-enqueue q s)
            )
            (else
               (let (
                     (s-l (vector-length s))
                  )
                  (let (
                        (a (make-vector (+ s-l 1)))
                        (b (make-vector (- t-l 1)))
                     )
                     (let loop ((k 0)) (if… (< k s-l) (then (vector-set! a k (vector-ref s k)) (loop (+ k 1)))))
                     (let loop (
                           (l 0)
                        )
                        (if… (< l t-l) (then
                           (let (
                                 (k (vector-ref t l))
                              )
                              (vector-set! a s-l k)
                              (let loop (
                                    (ll 0)
                                    (j 0)
                                 )
                                 (if… (< ll t-l) (then
                                    (let (
                                          (x (vector-ref t ll))
                                       )
                                       (if… (eqv? k x) (then
                                          (loop (+ ll 1) j)
                                       )
                                       (else
                                          (vector-set! b j x)
                                          (loop (+ ll 1) (+ j 1))
                                       ))
                                    )
                                 ))
                              )
                           )
                           (aux a b)
                           (loop (+ l 1))
                        ))
                     )
                  )
               )
            ))
         )
      )

      (let (
            (b (make-vector n))
         )
         (let loop ((k 0)) (if… (< k n) (then (vector-set! b k (+ k 1)) (loop (+ k 1)))))
         (aux '#() b)
         q
      )
   )
)

((lambda (n)
      (newline)
      (let (
            (q (perms n))
         )
         (display "(") (newline)
         (let loop (
            )
            (if… (not (ql-empty? q)) (then
               (display "   [")
               (let (
                     (a (ql-dequeue q))
                  )
                  (let loop (
                        (k 0)
                     )
                     (if… (< k (vector-length a)) (then
                        (display " ") (display (vector-ref a k)) (display ";")
                        (loop (+ k 1))
                     ))
                  )
               )
               (display " ];") (newline)
               (loop)
            ))
         )
         (display ")") (newline)
      )
      (newline)
      (exit exit-state)
   ) (let (
            (v (current-command-line-arguments))
         )
         (let (
               (n (if… (< 0 (vector-length v)) (then
                     (or (string->number (vector-ref v 0)) 0)
                  )
                  (else
                     0
                  ))
               )
            )
            (if… (< n 1) (then
               (ouch!)
            ))
            n
         )
      )
)

;* perms_m.rkt
% racket perms_m.rkt 3

(
   [ 1; 2; 3; ];
   [ 1; 3; 2; ];
   [ 2; 1; 3; ];
   [ 2; 3; 1; ];
   [ 3; 1; 2; ];
   [ 3; 2; 1; ];
)

% pp perms_m.ml
#mod_use "aej/daejana.ml" ;; open Daejana

let perms n =
   let rec aux q r b =
      if Array.length b < 1 then
         Queue.add r q
      else
(*
         for l = 0 to Array.length b - 1 do (
            let a = Array.append r (Array.make 1 b.(l))
            and t = Array.make (Array.length b - 1) 0 in
               for k = 0 to l - 1 do t.(k) <- b.(k) done ;
               if l < Array.length b - 1 then
                  for k = l to Array.length b - 2 do t.(k) <- b.(k + 1) done
               ;
               aux q a t
         ) done
*)
         for l = 0 to Array.length b - 1 do
            let a = Array.append r (Array.make 1 b.(l)) in
               aux q a (
                  if l < 1 then
                     Array.sub b 1 (Array.length b - 1)
                  else if l < Array.length b - 1 then
                     Array.append (Array.sub b 0 l) (Array.sub b (l + 1) (Array.length b - 1 - l))
                  else
                     Array.sub b 0 (Array.length b - 1)
               )
         done
   in
      let q = Queue.create ()
      and a = Array.make 0 0
      and b = Array.init n (fun k -> k + 1) in (
         aux q a b ;
         q
      )

let _ =
   print_newline () ;
   let n = if 1 < Array.length Sys.argv then int_of_string Sys.argv.(1) else 0 in (
      print_string "(" ; print_newline () ;
      if 0 < n then
         let q = perms n in
            Queue.iter (fun a ->
               print_string "   [" ;
               Array.iter (fun t -> print_string " " ; print_int t ; print_string "," ) a ;
               print_string " ];" ; print_newline () ;
            ) q
   ) ;
   print_string ")" ; print_newline () ;
   print_newline () ;
   ignore ()

(* perms_m.ml *)
% ocaml perms_m.ml 4

(
   [ 1, 2, 3, 4, ];
   [ 1, 2, 4, 3, ];
   [ 1, 3, 2, 4, ];
   [ 1, 3, 4, 2, ];
   [ 1, 4, 2, 3, ];
   [ 1, 4, 3, 2, ];
   [ 2, 1, 3, 4, ];
   [ 2, 1, 4, 3, ];
   [ 2, 3, 1, 4, ];
   [ 2, 3, 4, 1, ];
   [ 2, 4, 1, 3, ];
   [ 2, 4, 3, 1, ];
   [ 3, 1, 2, 4, ];
   [ 3, 1, 4, 2, ];
   [ 3, 2, 1, 4, ];
   [ 3, 2, 4, 1, ];
   [ 3, 4, 1, 2, ];
   [ 3, 4, 2, 1, ];
   [ 4, 1, 2, 3, ];
   [ 4, 1, 3, 2, ];
   [ 4, 2, 1, 3, ];
   [ 4, 2, 3, 1, ];
   [ 4, 3, 1, 2, ];
   [ 4, 3, 2, 1, ];
)

%