wazir_hamiltonian.ml

  type visited = Visited
  type free = Free
  type vi = visited
  type e = |

  type 'a chess = 'a
    constraint
      'a =
      <
      ul: _; up: _;       ur: _;
      le:_;  ce: vi; ri:_;
      dl:_;  dw: _;       dr:_;
      >

  type 'a l = 'a * 'a * 'a * 'a * 'a * 'a * 'a
  type 'a s = 'a l l

  type 't first = 'a * 'b * 'c * 'd *'e * 'f *'g
    constraint 't = 'a *('b * 'c *'d *'e * 'f *'g)


  type 't last = 'a * 'b * 'c * 'd *'e * 'f *'g
    constraint 't = ('a * 'b * 'c *'d *'e * 'f) *'g

  type start =
    < ul:vi s ; up:vi l;      ur:vi s ;
      le:vi l ; ce:vi;      ri: free l;
      ld:vi s; dw: free l; dr: free s
    >

  type 't fcol =
    ('l1 * 'r1) first
    * ('l2 * 'r2) first
    * ('l3 * 'r3) first
    * ('l4 * 'r4) first
    * ('l5 * 'r5) first
    * ('l6 * 'r6) first
    * ('l7 * 'r7) first
    constraint 't =
      ( 'l1 * 'l2 * 'l3 * 'l4 * 'l5 * 'l6 * 'l7 ) *
      ( 'r1 * 'r2 * 'r3 * 'r4 * 'r5 * 'r6 * 'r7 )

  type 't lcol =
    ('l1 * 'r1) last
    * ('l2 * 'r2) last
    * ('l3 * 'r3) last
    * ('l4 * 'r4) last
    * ('l5 * 'r5) last
    * ('l6 * 'r6) last
    * ('l7 * 'r7) last
    constraint 't =
      ( 'l1 * 'l2 * 'l3 * 'l4 * 'l5 * 'l6 * 'l7) *
      ( 'r1 * 'r2 * 'r3 * 'r4 * 'r5 * 'r6 * 'r7)

  type (_,_) move =
    | Right:(
        < ul:('ul * _) lcol ; up:'up;   ur:('nur * 'ur ) fcol;
          le:('le *_) last; ce:vi;   ri:(free * 'ri) first;
          ld:('ld * _) lcol ; dw:'dw; dr: ('ndr * 'dr) fcol;
    >,
    < ul:('up * 'ul) fcol; up:'nur;  ur:('ur * vi l) lcol;
      le:(vi * 'le) first; ce:vi;  ri:('ri * vi) last;
      ld:('dw * 'ld) fcol; dw:'ndr; dr: ('dr * vi l) lcol
    >
  ) move
    | Left:(
        < ul:('nul * 'ul) fcol ; up:'up;   ur:('ur * _ ) lcol;
          le:(free * 'le) first; ce:vi;   ri:('ri * _) last;
          ld:('nld * 'ld) fcol ; dw:'dw; dr: ('dr * _) lcol;
    >,
    < ul:('ul * vi l) lcol; up:'nul; ur:('up * 'ur) fcol;
      le:('le * vi) last;   ce:vi;   ri:(vi * 'ri) first;
      ld:('ld * vi l) lcol; dw:'nld; dr: ('dw * 'dr) fcol
    >
  ) move
  | Down:(
    < ul:('ul * _ ) last;        up:('up * _ ) last;  ur:('ur * _) last;
      le:'le;                    ce:vi;               ri:'ri;
      ld:('nld * 'ld) first; dw: (free * 'dw) first ; dr:('ndr * 'dr) first;
    >,
    < ul: ('le * 'ul) first ; up: (vi * 'up) first; ur: ('ri *'ur) first;
      le:'nld;                ce:vi;                ri:'ndr;
      ld:('ld * vi l) last;   dw:('dw * vi) last;   dr:('dr * vi l) last
    >
  ) move
    | Up:(
        < ul:('nul * 'ul) first; up:(free * 'up ) first;  ur:('nur * 'ur) first;
          le:'le;                ce:vi;                   ri:'ri;
          ld:('ld * _) last;     dw: ('dw * _) last ;     dr:('dr * _) last;
        >,
        < ul: ('ul * vi l) last; up:('up * vi) last;  ur: ('ur * vi l) last;
          le:'nul;               ce:vi;               ri:'nur;
          ld:('le * 'ld) first;  dw:(vi * 'dw) first; dr:('ri * 'dr) first
        >
      ) move

  type _ path =
    | []: start path
    | (::) : ('a,'b) move * 'a path -> 'b path

  type 'a ld = LD: <ld:'a; .. > path -> 'a ld
  type 'a le = L: <le:'a; .. > path -> 'a le

  let x = [Up;Right;Down]


  type hamiltonian = <ul: vi s; up: vi l; ur: vi s;
               le:vi l;  ce: vi  ; ri: vi l;
               ld: vi s; dw: vi l; dr: vi s
              >

 [@@@warning "@8"]
  let explore_all: hamiltonian path -> unit = function
    | [  _;_;_;_;_;_;_;
       _;_;_;_;_;_;_;_;
       _;_;_;_;_;_;_;_;
       _;_;_;_;_;_;_;_;
       _;_;_;_;_;_;_;_;
       _;_;_;_;_;_;_;_;
       _;_;_;_;_;_;_;_;
       _;_;_;_;_;_;_;_]
      -> .

  let all =
    [
           Left; Left; Left; Left; Left; Left; Left;
      Down;Right;Right;Right;Right;Right;Right;Right;
      Down; Left; Left; Left; Left; Left; Left; Left;
      Down;Right;Right;Right;Right;Right;Right;Right;
      Down; Left; Left; Left; Left; Left; Left; Left;
      Down;Right;Right;Right;Right;Right;Right;Right;
      Down; Left; Left; Left; Left; Left; Left; Left;
      Down;Right;Right;Right;Right;Right;Right;Right;
    ]

let crash = explore_all all