*        N-QUEENS PROBLEM          04/09/2015
         MACRO
&LAB     XDECO  &REG,&TARGET
&LAB     B      I&SYSNDX           branch around work area
P&SYSNDX DS     0D,PL8             packed
W&SYSNDX DS     CL13               char
I&SYSNDX CVD    &REG,P&SYSNDX          convert to decimal
         MVC    W&SYSNDX,=X'40202020202020202020212060'  nice mask
         EDMK   W&SYSNDX,P&SYSNDX+2    edit and mark
         BCTR   R1,0                   locate the right place
         MVC    0(1,R1),W&SYSNDX+12    move the sign
         MVC    &TARGET.(12),W&SYSNDX  move to target
         MEND
NQUEENS  CSECT
         SAVE   (14,12)            save registers on entry
         BALR   R12,0              establish addressability
         USING  *,R12              set base register
         ST     R13,SAVEA+4        link mySA->prevSA
         LA     R11,SAVEA          mySA
         ST     R11,8(R13)         link prevSA->mySA
         LR     R13,R11            set mySA pointer
         LA     R7,LL              l
         LA     R6,1               i=1
LOOPI    LR     R1,R6              do i=1 to l
         SLA    R1,1               i*2
         STH    R6,A-2(R1)         a(i)=i
         LA     R6,1(R6)           i=i+1
         BCT    R7,LOOPI           loop do i
OPENEM   OPEN   (OUTDCB,OUTPUT)    open the printer file
         LA     R9,1               n=1 start of loop
LOOPN    CH     R9,L               do n=1 to l
         BH     ELOOPN             if n>l then exit loop
         SR     R8,R8              m=0
         LA     R10,1              i=1
         LR     R5,R9              n
         SLA    R5,1               n*2
         BCTR   R5,0               r=2*n-1
E40      CR     R10,R9             if i>n
         BH     E80                then goto e80
         LR     R11,R10            j=i
E50      LR     R1,R10             i
         SLA    R1,1               i*2
         LA     R6,A-2(R1)         [email protected](i)
         LR     R1,R11             j
         SLA    R1,1               j*2
         LA     R7,A-2(R1)         [email protected](j)
         MVC    Z,0(R6)            z=a(i)
         MVC    Y,0(R7)            y=a(j)
         LR     R3,R10             i
         SH     R3,Y               -y
         AR     R3,R9              p=i-y+n
         LR     R4,R10             i
         AH     R4,Y               +y
         BCTR   R4,0               q=i+y-1
         MVC    0(2,R6),Y          a(i)=y
         MVC    0(2,R7),Z          a(j)=z
         LR     R1,R3              p
         SLA    R1,1               p*2
         LH     R2,U-2(R1)         u(p)
         LTR    R2,R2              if u(p)<>0
         BNE    E60                then goto e60
         LR     R1,R4              q
         AR     R1,R5              q+r
         SLA    R1,1               (q+r)*2
         LH     R2,U-2(R1)         u(q+r)
         C      R2,=F'0'           if u(q+r)<>0
         BNE    E60                then goto e60
         LR     R1,R10             i
         SLA    R1,1               i*2
         STH    R11,S-2(R1)        s(i)=j
         LA     R0,1               r0=1
         LR     R1,R3              p
         SLA    R1,1               p*2
         STH    R0,U-2(R1)         u(p)=1
         LR     R1,R4              q
         AR     R1,R5              q+r
         SLA    R1,1               (q+r)*2
         STH    R0,U-2(R1)         u(q+r)=1
         LA     R10,1(R10)         i=i+1
         B      E40                goto e40
E60      LA     R11,1(R11)         j=j+1
         CR     R11,R9             if j<=n
         BNH    E50                then goto e50
E70      BCTR   R11,0              j=j-1
         CR     R11,R10            if j=i
         BE     E90                goto e90
         LR     R1,R10             i
         SLA    R1,1               i*2
         LA     R6,A-2(R1)         [email protected](i)
         LR     R1,R11             j
         SLA    R1,1               j*2
         LA     R7,A-2(R1)         [email protected](j)
         MVC    Z,0(R6)            z=a(i)
         MVC    0(2,R6),0(R7)      a(i)=a(j)
         MVC    0(2,R7),Z          a(j)=z;
         B      E70                goto e70
E80      LA     R8,1(R8)           m=m+1
E90      BCTR   R10,0              i=i-1
         LTR    R10,R10            if i=0
         BZ     ZERO               then goto zero
         LR     R1,R10             i
         SLA    R1,1               i*2
         LH     R2,A-2(R1)         r2=a(i)
         LR     R3,R10             i
         SR     R3,R2              -a(i)
         AR     R3,R9              p=i-a(i)+n
         LR     R4,R10             i
         AR     R4,R2              +a(i)
         BCTR   R4,0               q=i+a(i)-1
         LR     R1,R10             i
         SLA    R1,1               i*2
         LH     R11,S-2(R1)        j=s(i)
         LA     R0,0               r0=0
         LR     R1,R3              p
         SLA    R1,1               p*2
         STH    R0,U-2(R1)         u(p)=0
         LR     R1,R4              q
         AR     R1,R5              q+r
         SLA    R1,1               (q+r)*2
         STH    R0,U-2(R1)         u(q+r)=0
         B      E60                goto e60
ZERO     XDECO  R9,PG+0            edit N
         XDECO  R8,PG+12           edit M
         PUT    OUTDCB,PG          print buffer
         LA     R9,1(R9)           n=n+1
         B      LOOPN              loop do n
ELOOPN   CLOSE  (OUTDCB)           close output
         L      R13,SAVEA+4        previous save area addrs
         RETURN (14,12),RC=0       return to caller with rc=0
         LTORG
SAVEA    DS     18F                save area for chaining
OUTDCB   DCB    DSORG=PS,MACRF=PM,DDNAME=OUTDD  use OUTDD in jcl
LL       EQU    14                 ll<=16
L        DC     AL2(LL)            input value
A        DS     (LL)H
S        DS     (LL)H
Z        DS     H
Y        DS     H
PG       DS     CL24               buffer
U        DC     (4*LL-2)H'0'       stack
         REGS                      make sure to include copybook jcl
         END    NQUEENS


TYPES: BEGIN OF gty_matrix,
         1  TYPE c,
         2  TYPE c,
         3  TYPE c,
         4  TYPE c,
         5  TYPE c,
         6  TYPE c,
         7  TYPE c,
         8  TYPE c,
         9  TYPE c,
         10 TYPE c,
       END OF gty_matrix,
       gty_t_matrix TYPE STANDARD TABLE OF gty_matrix INITIAL SIZE 8.

DATA: gt_matrix TYPE gty_t_matrix,
      gs_matrix TYPE gty_matrix,
      gv_count  TYPE i VALUE 0,
      gv_solut  TYPE i VALUE 0.

SELECTION-SCREEN BEGIN OF BLOCK b01 WITH FRAME TITLE text-b01.
PARAMETERS: p_number TYPE i OBLIGATORY DEFAULT 8.
SELECTION-SCREEN END OF BLOCK b01.

" Filling empty table
START-OF-SELECTION.
  DO p_number TIMES.
    APPEND gs_matrix TO gt_matrix.
  ENDDO.

" Recursive Function
  PERFORM fill_matrix USING gv_count 1 1 CHANGING gt_matrix.
  BREAK-POINT.
*&---------------------------------------------------------------------*
*&      Form  FILL_MATRIX
*----------------------------------------------------------------------*
FORM fill_matrix  USING    p_count TYPE i
                           p_i     TYPE i
                           p_j     TYPE i
                  CHANGING p_matrix TYPE gty_t_matrix.

  DATA: lv_i      TYPE i,
        lv_j      TYPE i,
        lv_result TYPE c LENGTH 1,
        lt_matrix TYPE gty_t_matrix,
        lv_count  TYPE i,
        lv_value  TYPE c.

  lt_matrix[] = p_matrix[].
  lv_count = p_count.
  lv_i = p_i.
  lv_j = p_j.

  WHILE lv_i LE p_number.
    WHILE lv_j LE p_number.
      CLEAR lv_result.
      PERFORM check_position USING lv_i lv_j CHANGING lv_result lt_matrix.
      IF lv_result NE 'X'.
        MOVE 'X' TO lv_value.
        PERFORM get_position USING lv_i lv_j 'U' CHANGING lv_value lt_matrix.
        ADD 1 TO lv_count.
        IF lv_count EQ p_number.
          PERFORM show_matrix USING lt_matrix.
        ELSE.
          PERFORM fill_matrix USING lv_count lv_i lv_j CHANGING lt_matrix.
        ENDIF.
        lv_value = space.
        PERFORM get_position USING lv_i lv_j 'U' CHANGING lv_value lt_matrix.
        SUBTRACT 1 FROM lv_count.
      ENDIF.
      ADD 1 TO lv_j.
    ENDWHILE.
    ADD 1 TO lv_i.
    lv_j = 1.
  ENDWHILE.
ENDFORM.                    " FILL_MATRIX

*&---------------------------------------------------------------------*
*&      Form  CHECK_POSITION
*&---------------------------------------------------------------------*
FORM check_position  USING value(p_i)  TYPE i
                           value(p_j)  TYPE i
                     CHANGING p_result TYPE c
                              p_matrix TYPE gty_t_matrix.

  PERFORM get_position USING p_i p_j 'R' CHANGING p_result p_matrix.
  CHECK p_result NE 'X'.

  PERFORM check_horizontal USING p_i p_j CHANGING p_result p_matrix.
  CHECK p_result NE 'X'.

  PERFORM check_vertical USING p_i p_j CHANGING p_result p_matrix.
  CHECK p_result NE 'X'.

  PERFORM check_diagonals USING p_i p_j CHANGING p_result p_matrix.

ENDFORM.                    " CHECK_POSITION

*&---------------------------------------------------------------------*
*&      Form  GET_POSITION
*&---------------------------------------------------------------------*
FORM get_position  USING value(p_i)      TYPE i
                         value(p_j)      TYPE i
                         value(p_action) TYPE c
                      CHANGING p_result  TYPE c
                               p_matrix  TYPE gty_t_matrix.

  FIELD-SYMBOLS: <fs_lmatrix> TYPE gty_matrix,
                 <fs_lfield> TYPE any.

  READ TABLE p_matrix ASSIGNING <fs_lmatrix> INDEX p_i.
  ASSIGN COMPONENT p_j OF STRUCTURE <fs_lmatrix> TO <fs_lfield>.

  CASE p_action.
    WHEN 'U'.
      <fs_lfield> = p_result.
    WHEN 'R'.
      p_result = <fs_lfield>.
    WHEN OTHERS.
  ENDCASE.

ENDFORM.                    " GET_POSITION

*&---------------------------------------------------------------------*
*&      Form  CHECK_HORIZONTAL
*&---------------------------------------------------------------------*
FORM check_horizontal  USING value(p_i)      TYPE i
                             value(p_j)      TYPE i
                          CHANGING p_result  TYPE c
                                   p_matrix  TYPE gty_t_matrix.
  DATA: lv_j TYPE i,
        ls_matrix TYPE gty_matrix.

  FIELD-SYMBOLS <fs> TYPE c.

  lv_j = 1.
  READ TABLE p_matrix INTO ls_matrix INDEX p_i.
  WHILE lv_j LE p_number.
    ASSIGN COMPONENT lv_j OF STRUCTURE ls_matrix TO <fs>.
    IF <fs> EQ 'X'.
      p_result = 'X'.
      RETURN.
    ENDIF.
    ADD 1 TO lv_j.
  ENDWHILE.
ENDFORM.                    " CHECK_HORIZONTAL

*&---------------------------------------------------------------------*
*&      Form  CHECK_VERTICAL
*&---------------------------------------------------------------------*
FORM check_vertical  USING value(p_i)      TYPE i
                           value(p_j)      TYPE i
                        CHANGING p_result  TYPE c
                                 p_matrix  TYPE gty_t_matrix.
  DATA: lv_i TYPE i,
        ls_matrix TYPE gty_matrix.

  FIELD-SYMBOLS <fs> TYPE c.

  lv_i = 1.
  WHILE lv_i LE p_number.
    READ TABLE p_matrix INTO ls_matrix INDEX lv_i.
    ASSIGN COMPONENT p_j OF STRUCTURE ls_matrix TO <fs>.
    IF <fs> EQ 'X'.
      p_result = 'X'.
      RETURN.
    ENDIF.
    ADD 1 TO lv_i.
  ENDWHILE.
ENDFORM.                    " CHECK_VERTICAL

*&---------------------------------------------------------------------*
*&      Form  CHECK_DIAGONALS
*&---------------------------------------------------------------------*
FORM check_diagonals  USING value(p_i)      TYPE i
                            value(p_j)      TYPE i
                         CHANGING p_result  TYPE c
                                  p_matrix  TYPE gty_t_matrix.
  DATA: lv_dx TYPE i,
        lv_dy TYPE i.

* I++ J++ (Up Right)
  lv_dx = 1.
  lv_dy = 1.
  PERFORM check_diagonal USING p_i p_j lv_dx lv_dy CHANGING p_result p_matrix.
  CHECK p_result NE 'X'.

* I-- J-- (Left Down)
  lv_dx = -1.
  lv_dy = -1.
  PERFORM check_diagonal USING p_i p_j lv_dx lv_dy CHANGING p_result p_matrix.
  CHECK p_result NE 'X'.

* I++ J-- (Right Down)
  lv_dx = 1.
  lv_dy = -1.
  PERFORM check_diagonal USING p_i p_j lv_dx lv_dy CHANGING p_result p_matrix.
  CHECK p_result NE 'X'.

* I-- J++ (Left Up)
  lv_dx = -1.
  lv_dy = 1.
  PERFORM check_diagonal USING p_i p_j lv_dx lv_dy CHANGING p_result p_matrix.
  CHECK p_result NE 'X'.
ENDFORM.                    " CHECK_DIAGONALS

*&---------------------------------------------------------------------*
*&      Form  CHECK_DIAGONAL
*&---------------------------------------------------------------------*
FORM check_diagonal  USING value(p_i)      TYPE i
                            value(p_j)      TYPE i
                            value(p_dx)      TYPE i
                            value(p_dy)      TYPE i
                         CHANGING p_result  TYPE c
                                  p_matrix  TYPE gty_t_matrix.
  DATA: lv_i TYPE i,
        lv_j TYPE i,
        ls_matrix TYPE gty_matrix.

  FIELD-SYMBOLS <fs> TYPE c.

  lv_i = p_i.
  lv_j = p_j.
  WHILE 1 EQ 1.
    ADD: p_dx TO lv_i, p_dy TO lv_j.

    IF p_dx EQ 1.
      IF lv_i GT p_number. EXIT. ENDIF.
    ELSE.
      IF lv_i LT 1. EXIT. ENDIF.
    ENDIF.

    IF p_dy EQ 1.
      IF lv_j GT p_number. EXIT. ENDIF.
    ELSE.
      IF lv_j LT 1. EXIT. ENDIF.
    ENDIF.

    READ TABLE p_matrix INTO ls_matrix INDEX lv_i.
    ASSIGN COMPONENT lv_j OF STRUCTURE ls_matrix TO <fs>.
    IF <fs> EQ 'X'.
      p_result = 'X'.
      RETURN.
    ENDIF.
  ENDWHILE.
ENDFORM.                    " CHECK_DIAGONAL
*&---------------------------------------------------------------------*
*&      Form  SHOW_MATRIX
*----------------------------------------------------------------------*
FORM show_matrix USING p_matrix TYPE gty_t_matrix.
  DATA: lt_matrix TYPE gty_t_matrix,
        lv_j      TYPE i VALUE 1,
        lv_colum  TYPE string VALUE '-'.

  FIELD-SYMBOLS: <fs_matrix> TYPE gty_matrix,
                 <fs_field>  TYPE c.

  ADD 1 TO gv_solut.

  WRITE:/ 'Solution: ', gv_solut.

  DO p_number TIMES.
    CONCATENATE lv_colum '----' INTO lv_colum.
  ENDDO.

  LOOP AT p_matrix ASSIGNING <fs_matrix>.
    IF sy-tabix EQ 1.
      WRITE:/ lv_colum.
    ENDIF.
    WRITE:/ '|'.
    DO p_number TIMES.
      ASSIGN COMPONENT lv_j OF STRUCTURE <fs_matrix> TO <fs_field>.
      IF <fs_field> EQ space.
        WRITE: <fs_field> ,'|'.
      ELSE.
        WRITE: <fs_field> COLOR 2 HOTSPOT ON,'|'.
      ENDIF.
      ADD 1 TO lv_j.
    ENDDO.
    lv_j = 1.
    WRITE: / lv_colum.
  ENDLOOP.

  SKIP 1.
ENDFORM.                    " SHOW_MATRIX


with Ada.Text_IO;  use Ada.Text_IO;

procedure Queens is
   Board : array (1..8, 1..8) of Boolean := (others => (others => False));
   function Test (Row, Column : Integer) return Boolean is
   begin
      for J in 1..Column - 1 loop
         if (  Board (Row, J)
            or else
               (Row > J and then Board (Row - J, Column - J))
            or else
               (Row + J <= 8 and then Board (Row + J, Column - J))
            )  then
            return False;
         end if;
      end loop;
      return True;
   end Test;
   function Fill (Column : Integer) return Boolean is
   begin
      for Row in Board'Range (1) loop
         if Test (Row, Column) then
            Board (Row, Column) := True;
            if Column = 8 or else Fill (Column + 1) then
               return True;
            end if;
            Board (Row, Column) := False;
         end if;
      end loop;
      return False;
   end Fill;
begin
   if not Fill (1) then
      raise Program_Error;
   end if;
   for I in Board'Range (1) loop
      Put (Integer'Image (9 - I));
      for J in Board'Range (2) loop
         if Board (I, J) then
            Put ("|Q");
         elsif (I + J) mod 2 = 1 then
            Put ("|/");
         else
            Put ("| ");
         end if;
      end loop;
      Put_Line ("|");
   end loop;
   Put_Line ("   A B C D E F G H");
end Queens;


INT ofs = 1, # Algol68 normally uses array offset of 1 #
    dim = 8; # dim X dim chess board #
[ofs:dim+ofs-1]INT b;

PROC unsafe = (INT y)BOOL:(
  INT i, t, x;
  x := b[y];
  FOR i TO y - LWB b DO
    t := b[y - i];
    IF t = x THEN break true
    ELIF t = x - i THEN break true
    ELIF t = x + i THEN break true
    FI
  OD;
  FALSE EXIT
break true:
  TRUE
);

INT s := 0;

PROC print board = VOID:(
  INT x, y;
  print((new line, "Solution # ", s+:=1, new line));
  FOR y FROM LWB b TO UPB b DO
    FOR x FROM LWB b TO UPB b DO
      print("|"+(b[y]=x|"Q"|: ODD(x+y)|"/"|" "))
    OD;
    print(("|", new line))
  OD
);

main: (
  INT y := LWB b;
  b[LWB b] := LWB b - 1;
  FOR i WHILE y >= LWB b DO
    WHILE
      b[y]+:=1;
  # BREAK # IF b[y] <= UPB b THEN unsafe(y) ELSE FALSE FI
    DO SKIP OD;
    IF b[y] <= UPB b  THEN
      IF y < UPB b THEN
        b[y+:=1] := LWB b - 1
      ELSE
        print board
      FI
    ELSE
      y-:=1
    FI
  OD
)


⍝Solution
accm←{⍺,((⍴⍵)=⍴⊃⍺)↑⊂⍵}
atk←{∪∊(⊂⍵)+¯1 0 1×⊂⌽⍳⍴⍵}
dfs←{⊃∇⍨/⌽(⊂⍺ ⍺⍺ ⍵),⍺ ⍵⍵ ⍵}
qfmt←{⍵∘.=⍳⍴⍵}
subs←{(⊂⍵),¨(⍳⍴⊃⍺)~atk ⍵}
queens←{qfmt¨(↓0 ⍵⍴0)accm dfs subs ⍬}
printqueens←{i←1⋄{⎕←'answer'i⋄⎕←⍵⋄i+←1}¨queens ⍵}

⍝Example
printqueens 6


-- Finds all possible solutions and the unique patterns.

property Grid_Size : 8

property Patterns : {}
property Solutions : {}
property Test_Count : 0

property Rotated : {}

on run
    local diff
    local endTime
    local msg
    local rows
    local startTime

    set Patterns to {}
    set Solutions to {}
    set Rotated to {}

    set Test_Count to 0

    set rows to Make_Empty_List(Grid_Size)

    set startTime to current date
    Solve(1, rows)
    set endTime to current date
    set diff to endTime - startTime

    set msg to ("Found " & (count Solutions) & " solutions with " & (count Patterns) & " patterns in " & diff & " seconds.") as text
    display alert msg

    return Solutions
end run

on Solve(row as integer, rows as list)
    if row is greater than (count rows) then
        Append_Solution(rows)
        return
    end if

    repeat with column from 1 to Grid_Size
        set Test_Count to Test_Count + 1
        if Place_Queen(column, row, rows) then
            Solve(row + 1, rows)
        end if
    end repeat
end Solve

on abs(n)
    if n < 0 then
        -n
    else
        n
    end if
end abs

on Place_Queen(column as integer, row as integer, rows as list)
    local colDiff
    local previousRow
    local rowDiff
    local testColumn

    repeat with previousRow from 1 to (row - 1)
        set testColumn to item previousRow of rows

        if testColumn is equal to column then
            return false
        end if

        set colDiff to abs(testColumn - column) as integer
        set rowDiff to row - previousRow
        if colDiff is equal to rowDiff then
            return false
        end if
    end repeat

    set item row of rows to column
    return true
end Place_Queen

on Append_Solution(rows as list)
    local column
    local rowsCopy
    local testReflection
    local testReflectionText
    local testRotation
    local testRotationText
    local testRotations

    copy rows to rowsCopy
    set end of Solutions to rowsCopy
    local rowsCopy

    copy rows to testRotation
    set testRotations to {}
    repeat 3 times
        set testRotation to Rotate(testRotation)
        set testRotationText to testRotation as text
        if Rotated contains testRotationText then
            return
        end if
        set end of testRotations to testRotationText

        set testReflection to Reflect(testRotation)
        set testReflectionText to testReflection as text
        if Rotated contains testReflectionText then
            return
        end if
        set end of testRotations to testReflectionText
    end repeat

    repeat with testRotationText in testRotations
        set end of Rotated to (contents of testRotationText)
    end repeat
    set end of Rotated to (rowsCopy as text)
    set end of Rotated to (Reflect(rowsCopy) as text)

    set end of Patterns to rowsCopy
end Append_Solution

on Make_Empty_List(depth as integer)
    local i
    local emptyList

    set emptyList to {}
    repeat with i from 1 to depth
        set end of emptyList to missing value
    end repeat
    return emptyList
end Make_Empty_List

on Rotate(rows as list)
    local column
    local newColumn
    local newRow
    local newRows
    local row
    local rowCount

    set rowCount to (count rows)
    set newRows to Make_Empty_List(rowCount)
    repeat with row from 1 to rowCount
        set column to (contents of item row of rows)
        set newRow to column
        set newColumn to rowCount - row + 1
        set item newRow of newRows to newColumn
    end repeat

    return newRows
end Rotate

on Reflect(rows as list)
    local column
    local newRows

    set newRows to {}
    repeat with column in rows
        set end of newRows to (count rows) - column + 1
    end repeat

    return newRows
end Reflect


(def nqueens (n (o queens))
  (if (< len.queens n)
    (let row (if queens (+ 1 queens.0.0) 0)
      (each col (range 0 (- n 1))
        (let new-queens (cons (list row col) queens)
          (if (no conflicts.new-queens)
            (nqueens n new-queens)))))
    (prn queens)))

; check if the first queen in 'queens' lies on the same column or diagonal as
; any of the others
(def conflicts (queens)
  (let (curr . rest) queens
    (or (let curr-column curr.1
          (some curr-column (map [_ 1] rest)))  ; columns
        (some [diagonal-match curr _] rest))))

(def diagonal-match (curr other)
  (is (abs (- curr.0 other.0))
      (abs (- curr.1 other.1))))


result: new []

queens: function [n, i, a, b, c][
    if? i < n [
        loop 1..n 'j [
            if all? @[
                not? contains? a j
                not? contains? b i+j
                not? contains? c i-j
            ] ->
                queens n, i+1, a ++ @[j], b ++ @[i+j], c ++ @[i-j]

        ]
    ]
    else [
        if n = size a ->
        'result ++ @[a]
    ]
]

BoardSize: 6

queens BoardSize, 0, [], [], []
loop result 'solution [
    loop solution 'col [

        line: new repeat "-" BoardSize
        line\[col-1]: `Q`
        print line
    ]
    print ""
]


#!/usr/bin/gawk -f
# Solve the Eight Queens Puzzle
#    Inspired by Raymond Hettinger [https://code.activestate.com/recipes/576647/]
#    Just the vector of row positions per column is kept,
#    and filled with all possibilities from left to right recursively,
#    then checked against the columns left from the current one:
#    - is a queen in the same row
#    - is a queen in the digonal
#    - is a queen in the reverse diagonal
BEGIN {
    dim = ARGC < 2 ? 8 : ARGV[1]
    # make vec an array
    vec[1] = 0
    # scan for a solution
    if (tryqueen(1, vec, dim))
        result(vec, dim)
    else
        print "No solution with " dim " queens."
}

# try if a queen can be set in column (col)
function tryqueen(col, vec, dim,        new)  {
    for (new = 1; new <= dim; ++new) {
        # check all previous columns
        if (noconflict(new, col, vec, dim)) {
            vec[col] = new
            if (col == dim)
                return 1
            # must try next column(s)
           if (tryqueen(col+1, vec, dim))
                return 1
        }
    }
    # all tested, failed
    return 0
}

#  check if setting the queen (new) in column (col) is ok
#  by checking the previous colums conflicts
function noconflict(new, col, vec, dim,    j) {
    for (j = 1; j < col; j++) {
        if (vec[j] == new)
            return 0    # same row
        if (vec[j] == new - col + j)
            return 0        # diagonal conflict
        if (vec[j] == new + col - j)
            return 0        # reverse diagonal conflict
    }
    # no test failed, no conflict
    return 1
}

# print matrix
function result(vec, dim,    row, col, sep, lne) {
    # print the solution vector
    for (row  = 1; row <= dim; ++row)
        printf " %d", vec[row]
    print

    # print a board matrix
    for (row = 1; row <= dim; ++row) {
        lne = "|"
        for (col = 1; col <= dim; ++col) {
            if (row == vec[col])
                lne = lne "Q|"
            else
                lne = lne "_|"
        }
        print lne
    }
}


(* ****** ****** *)
//
// Solving N-queen puzzle
//
(* ****** ****** *)
//
// How to test:
// ./queens
// How to compile:
// patscc -DATS_MEMALLOC_LIBC -o queens queens.dats
//
(* ****** ****** *)
//
#include
"share/atspre_staload.hats"
//
#include
"share/HATS/atspre_staload_libats_ML.hats"
//
(* ****** ****** *)

fun
solutions(N:int) = let
//
fun
show
(
  board: list0(int)
) : void =
(
  list0_foreach<int>
  ( list0_reverse(board)
  , lam(n) => ((N).foreach()(lam(i) => print_string(if i = n then " Q" else " _")); print_newline())
  ) ;
  print_newline()
)
//
fun
safe
(
  i: int, j: int, k: int, xs: list0(int)
) : bool =
(
  case+ xs of
  | nil0() => true
  | cons0(x, xs) => x != i && x != j && x != k && safe(i, j+1, k-1, xs)
)
//
fun
loop
(
  col: int, xs: list0(int)
) : void =
(N).foreach()
(
lam(i) =>
if
safe(i, i+1, i-1, xs)
then let
  val xs = cons0(i, xs)
in
  if col = N then show(xs) else loop(col+1, xs)
end // end of [then]
)
//
in
  loop(1, nil0())
end // end of [solutions]

(* ****** ****** *)

val () = solutions(8)

(* ****** ****** *)

implement main0() = ()

(* ****** ****** *)

(* end of [queens.dats] *)


;
; Post: http://www.autohotkey.com/forum/viewtopic.php?p=353059#353059
; Timestamp: 05/may/2010
;

MsgBox % funcNQP(5)
MsgBox % funcNQP(8)

Return

;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
;
; ** USED VARIABLES **
;
; Global: All variables named Array[???]
;
; Function funcNPQ: nQueens , OutText , qIndex
;
; Function Unsafe: nIndex , Idx , Tmp , Aux
;
; Function PutBoard: Output , QueensN , Stc , xxx , yyy
;
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

funcNQP(nQueens)
{
  Global
  Array[0] := -1
  Local OutText , qIndex := 0
  While ( qIndex >= 0 )
  {
    Array[%qIndex%]++
    While ( (Array[%qIndex%] < nQueens) && Unsafe(qIndex) )
      Array[%qIndex%]++
    If ( Array[%qIndex%] < nQueens )
    {
      If ( qIndex < nQueens-1 )
        qIndex++  ,  Array[%qIndex%] := -1
      Else
        PutBoard(OutText,nQueens)
    }
    Else
      qIndex--
  }
  Return OutText
}

;------------------------------------------

Unsafe(nIndex)
{
  Global
  Local Idx := 1  ,  Tmp := 0  ,  Aux := Array[%nIndex%]
  While ( Idx <= nIndex )
  {
    Tmp := "Array[" nIndex - Idx "]"
    Tmp := % %Tmp%
    If ( ( Tmp = Aux ) || ( Tmp = Aux-Idx ) || ( Tmp = Aux+Idx ) )
      Return 1
    Idx++
  }
  Return 0
}

;------------------------------------------

PutBoard(ByRef Output,QueensN)
{
  Global
  Static Stc = 0
  Local xxx := 0 , yyy := 0
  Output .= "`n`nSolution #" (++Stc) "`n"
  While ( yyy < QueensN )
  {
    xxx := 0
    While ( xxx < QueensN )
      Output .= ( "|" ( ( Array[%yyy%] = xxx ) ? "Q" : "_" ) )  ,  xxx++
    Output .= "|`n"  ,  yyy++
  }
}


      Size% = 8
      Cell% = 32
      VDU 23,22,Size%*Cell%;Size%*Cell%;Cell%,Cell%,16,128+8,5
      *font Arial Unicode MS,16
      GCOL 3,11
      FOR i% = 0 TO Size%-1 STEP 2
        RECTANGLE FILL i%*Cell%*2,0,Cell%*2,Size%*Cell%*2
        RECTANGLE FILL 0,i%*Cell%*2,Size%*Cell%*2,Cell%*2
      NEXT
      num% = FNqueens(Size%, Cell%)
      SYS "SetWindowText", @hwnd%, "Total " + STR$(num%) + " solutions"
      REPEAT : WAIT 1 : UNTIL FALSE
      END

      DEF FNqueens(n%, s%)
      LOCAL i%, j%, m%, p%, q%, r%, a%(), b%(), c%()
      DIM a%(n%), b%(n%), c%(4*n%-2)
      FOR i% = 1 TO DIM(a%(),1) : a%(i%) = i% : NEXT
      m% = 0
      i% = 1
      j% = 0
      r% = 2*n%-1
      REPEAT
        i% -= 1
        j% += 1
        p% = 0
        q% = -r%
        REPEAT
          i% += 1
          c%(p%) = 1
          c%(q%+r%) = 1
          SWAP a%(i%),a%(j%)
          p% = i% - a%(i%) + n%
          q% = i% + a%(i%) - 1
          b%(i%) = j%
          j% = i% + 1
        UNTIL j% > n% OR c%(p%) OR c%(q%+r%)
        IF c%(p%)=0 IF c%(q%+r%)=0 THEN
          IF m% = 0 THEN
            FOR p% = 1 TO n%
              MOVE 2*s%*(a%(p%)-1)+6, 2*s%*p%+6
              PRINT "♛";
            NEXT
          ENDIF
          m% += 1
        ENDIF
        j% = b%(i%)
        WHILE j% >= n% AND i% <> 0
          REPEAT
            SWAP a%(i%), a%(j%)
            j% = j%-1
          UNTIL j% < i%
          i% -= 1
          p% = i% - a%(i%) + n%
          q% = i% + a%(i%) - 1
          j% = b%(i%)
          c%(p%) = 0
          c%(q%+r%) = 0
        ENDWHILE
      UNTIL i% = 0
      = m%


// This can be run using Cintcode BCPL freely available from www.cl.cam.ac.uk/users/mr10.

GET "libhdr.h"

GLOBAL { count:ug; all  }

LET try(ld, row, rd) BE TEST row=all

                        THEN count := count + 1

                        ELSE { LET poss = all & ~(ld | row | rd)
                               WHILE poss DO
                               { LET p = poss & -poss
                                 poss := poss - p
                                 try(ld+p << 1, row+p, rd+p >> 1)
                               }
                             }

LET start() = VALOF
{ all := 1

  FOR i = 1 TO 16 DO
  { count := 0
    try(0, 0, 0)
    writef("Number of solutions to %i2-queens is %i7*n", i, count)
    all := 2*all + 1
  }

  RESULTIS 0
}


(   ( printBoard
    =   board M L x y S R row line
      .   :?board
        & !ups:? [?M
        &   whl
          ' ( !arg:(?x.?y) ?arg
            & !M:?L
            & :?row:?line
            &   whl
              ' ( !L+-1:~<0:?L
                & !x+1:~>!M:?x
                & "---+" !line:?line
                & "   |" !row:?row
                )
            & "---+" !line:?line
            & " Q |" !row:?row
            &   whl
              ' ( !L+-1:~<0:?L
                & "---+" !line:?line
                & "   |" !row:?row
                )
            & "\n|" !row "\n+" !line !board:?board
            )
        & str$("\n+" !line !board)
    )
    ( queens
    =   hor ver up down ups downs a z A Z x y Q
      .   !arg:(?hor.?ver.?ups.?downs.?Q)
        &   !ver
          : (
              & 1+!solutions:?solutions
              { Comment the line below if you only want a count. }
              & out$(str$("\nsolution " !solutions) printBoard$!Q)
              & ~  { Fail! (and backtrack to find more solutions)}
            |   #%?y
                ( ?z
                &   !hor
                  :   ?A
                      #%?x
                      ( ?Z
                      & !x+!y:?up
                      & !x+-1*!y:?down
                      & ~(!ups:? !up ?)
                      & ~(!downs:? !down ?)
                      &   queens
                        $ ( !A !Z
                          . !z
                          . !up !ups
                          . !down !downs
                          . (!x.!y) !Q
                          )
                      )
                )
            )
    )
& 0:?solutions
& 1 2 3 4 5 6 7 8:?H:?V   {You can edit this line to find solutions for other sizes.}
& ( queens$(!H.!V...)
  | out$(found !solutions solutions)
  )
);


#include <stdio.h>
#include <stdlib.h>

int count = 0;
void solve(int n, int col, int *hist)
{
	if (col == n) {
		printf("\nNo. %d\n-----\n", ++count);
		for (int i = 0; i < n; i++, putchar('\n'))
			for (int j = 0; j < n; j++)
				putchar(j == hist[i] ? 'Q' : ((i + j) & 1) ? ' ' : '.');

		return;
	}

#	define attack(i, j) (hist[j] == i || abs(hist[j] - i) == col - j)
	for (int i = 0, j = 0; i < n; i++) {
		for (j = 0; j < col && !attack(i, j); j++);
		if (j < col) continue;

		hist[col] = i;
		solve(n, col + 1, hist);
	}
}

int main(int n, char **argv)
{
	if (n <= 1 || (n = atoi(argv[1])) <= 0) n = 8;
	int hist[n];
	solve(n, 0, hist);
}


using System.Collections.Generic;
using static System.Linq.Enumerable;
using static System.Console;
using static System.Math;

namespace N_Queens
{
    static class Program
    {
        static void Main(string[] args)
        {
            var n = 8;
            var cols = Range(0, n);
            var combs = cols.Combinations(2).Select(pairs=> pairs.ToArray());
            var solved = from v in cols.Permutations().Select(p => p.ToArray())
                         where combs.All(c => Abs(v[c[0]] - v[c[1]]) != Abs(c[0] - c[1]))
                         select v;

            WriteLine($"{n}-queens has {solved.Count()} solutions");
            WriteLine("Position is row, value is column:-");
            var first = string.Join(" ", solved.First());
            WriteLine($"First Solution: {first}");
            Read();
        }

        //Helpers
        public static IEnumerable<IEnumerable<T>> Permutations<T>(this IEnumerable<T> values)
        {
            if (values.Count() == 1)
                return values.ToSingleton();

            return values.SelectMany(v => Permutations(values.Except(v.ToSingleton())), (v, p) => p.Prepend(v));
        }

        public static IEnumerable<IEnumerable<T>> Combinations<T>(this IEnumerable<T> seq) =>
            seq.Aggregate(Empty<T>().ToSingleton(), (a, b) => a.Concat(a.Select(x => x.Append(b))));

        public static IEnumerable<IEnumerable<T>> Combinations<T>(this IEnumerable<T> seq, int numItems) =>
            seq.Combinations().Where(s => s.Count() == numItems);

        public static IEnumerable<T> ToSingleton<T>(this T item) { yield return item; }
    }
}


// Much shorter than the version below;
// uses C++11 threads to parallelize the computation; also uses backtracking
// Outputs all solutions for any table size
#include <vector>
#include <iostream>
#include <iomanip>
#include <thread>
#include <future>

// Print table. 'pos' is a vector of positions – the index in pos is the row,
// and the number at that index is the column where the queen is placed.
static void print(const std::vector<int> &pos)
{
	// print table header
	for (int i = 0; i < pos.size(); i++) {
		std::cout << std::setw(3) << char('a' + i);
	}

	std::cout << '\n';

	for (int row = 0; row < pos.size(); row++) {
		int col = pos[row];
		std::cout << row + 1 << std::setw(3 * col + 3) << " # ";
		std::cout << '\n';
	}

	std::cout << "\n\n";
}

static bool threatens(int row_a, int col_a, int row_b, int col_b)
{
	return row_a == row_b // same row
		or col_a == col_b // same column
		or std::abs(row_a - row_b) == std::abs(col_a - col_b); // diagonal
}

// the i-th queen is in the i-th row
// we only check rows up to end_idx
// so that the same function can be used for backtracking and checking the final solution
static bool good(const std::vector<int> &pos, int end_idx)
{
	for (int row_a = 0; row_a < end_idx; row_a++) {
		for (int row_b = row_a + 1; row_b < end_idx; row_b++) {
			int col_a = pos[row_a];
			int col_b = pos[row_b];
			if (threatens(row_a, col_a, row_b, col_b)) {
				return false;
			}
		}
	}

	return true;
}

static std::mutex print_count_mutex; // mutex protecting 'n_sols'
static int n_sols = 0; // number of solutions

// recursive DFS backtracking solver
static void n_queens(std::vector<int> &pos, int index)
{
	// if we have placed a queen in each row (i. e. we are at a leaf of the search tree), check solution and return
	if (index >= pos.size()) {
		if (good(pos, index)) {
			std::lock_guard<std::mutex> lock(print_count_mutex);
			print(pos);
			n_sols++;
		}

		return;
	}

	// backtracking step
	if (not good(pos, index)) {
		return;
	}

	// optimization: the first level of the search tree is parallelized
	if (index == 0) {
		std::vector<std::future<void>> fts;
		for (int col = 0; col < pos.size(); col++) {
			pos[index] = col;
			auto ft = std::async(std::launch::async, [=]{ auto cpos(pos); n_queens(cpos, index + 1); });
			fts.push_back(std::move(ft));
		}

		for (const auto &ft : fts) {
			ft.wait();
		}
	} else { // deeper levels are not
		for (int col = 0; col < pos.size(); col++) {
			pos[index] = col;
			n_queens(pos, index + 1);
		}
	}
}

int main()
{
	std::vector<int> start(12); // 12: table size
	n_queens(start, 0);
	std::cout << n_sols << " solutions found.\n";
	return 0;
}


(def size 8)

(defn extends? [v n]
  (let [k (count v)]
    (not-any? true?
      (for [i (range k) :let [vi (v i)]]
        (or
          (= vi n)  ;check for shared row
          (= (- k i) (Math/abs (- n vi)))))))) ;check for shared diagonal

(defn extend [vs]
  (for [v vs
        n (range 1 (inc size)) :when (extends? v n)]
    (conj v n)))

(def solutions
  (nth (iterate extend [[]]) size))

(doseq [s solutions]
  (println s))

(println (count solutions) "solutions")


n_queens = cluster is solve
    rep = null
    own hist: array[int] := array[int]$[]
    own solutions: array[string] := array[string]$[]

    attack = proc (i,j,col: int) returns (bool)
        return(hist[j]=i | int$abs(hist[j]-i)=col-j)
    end attack

    cur_solution = proc ()
        n: int := array[int]$size(hist)
        ss: stream := stream$create_output()

        for i: int in int$from_to(0,n-1) do
            for j: int in int$from_to(0,n-1) do
                if j=hist[i] then stream$putc(ss, 'Q')
                elseif (i+j)//2 = 1 then stream$putc(ss, ' ')
                else stream$putc(ss, '.')
                end
            end
            stream$putc(ss, '\n')
        end

        array[string]$addh(solutions, stream$get_contents(ss))
    end cur_solution

    solve_rec = proc (col: int)
        n: int := array[int]$size(hist)
        if col=n then cur_solution() return end

        for i: int in int$from_to(0,n-1) do
            j: int := 0
            while j<col cand ~attack(i,j,col) do j := j+1 end
            if j<col then continue end
            hist[col] := i
            solve_rec(col+1)
        end
    end solve_rec

    solve = proc (n: int) returns (sequence[string])
        hist := array[int]$fill(0,n,0)
        solutions := array[string]$[]
        solve_rec(0)
        return(sequence[string]$a2s(solutions))
    end solve
end n_queens

start_up = proc()
    N = 8

    po: stream := stream$primary_output()
    solutions: sequence[string] := n_queens$solve(N)

    count: int := 0
    for s: string in sequence[string]$elements(solutions) do
        count := count + 1
        stream$putl(po, "No. " || int$unparse(count) || "\n-------\n" || s)
    end
end start_up


# Unlike traditional N-Queens solutions that use recursion, this
# program attempts to more closely model the "human" algorithm.
#
# In this algorithm, the function keeps placing queens on the board
# until there is no longer a safe square.  If the 8th queen has been
# placed, the solution is noted.  If fewer than 8th queens have been
# placed, then you are at a dead end.  In either case, backtracking occurs.
# The LAST queen placed on the board gets pulled, then it gets moved
# to the next safe square.  (We backtrack even after a "good" attempt in
# order to get to a new solution.)  This backtracking may repeat itself
# several times until the original misplaced queen finally is proven to
# be a dead end.
#
# Many N-Queens solutions use lazy logic (along with geometry shortcuts)
# to determine whether a queen is under attack.  In this algorithm, we
# are more proactive, essentially updating a sieve every time we lay a
# queen down.  To make backtracking easier, the sieve uses ref-counts vs.
# a simple safe/unsafe boolean.
#
# We precompute the "attack graph" up front, and then we essentially ignore
# the geometry of the problem.  This approach, while perhaps suboptimal for
# queens, probably is more flexible for general "coexistence" problems.
nqueens = (n) ->
  neighbors = precompute_neighbors(n)

  board = []
  num_solutions = 0
  num_backtracks = 0
  queens = []
  pos = 0

  for p in [0...n*n]
    board.push 0

  attack = (pos, delta=1) ->
    for neighbor in neighbors[pos]
      board[neighbor] += delta

  backtrack = ->
    pos = queens.pop()
    attack pos, -1 # unattack queen you just pulled
    pos += 1
    num_backtracks += 1

  # The following loop finds all 92 solutions to
  # the 8-queens problem (for n=8).
  while true
    if pos >= n*n
      if queens.length == 0
        break
      backtrack()
      continue

    # If a square is empty
    if board[pos] == 0
      attack pos
      queens.push pos
      if queens.length == n
        num_solutions += 1
        show_queens queens, n
        backtrack()
    pos += 1

  console.log "#{num_solutions} solutions"
  console.log "#{num_backtracks} backtracks"

precompute_neighbors = (n) ->
  # For each board position, build a list of all
  # the board positions that would be under attack if
  # you placed a queen on it.  This assumes a 1d array
  # of squares.
  neighbors = []

  find_neighbors = (pos) ->
    arr = []
    row = Math.floor pos / n
    col = pos % n
    for i in [0...n]
      if i != col
        arr.push row*n + i
        r1 = row + col - i
        r2 = row + i - col
        if 0 <= r1 and r1 < n
          arr.push r1*n + i
        if 0 <= r2 and r2 < n
          arr.push r2*n + i
      if i != row
        arr.push i*n + col
    arr

  for pos in [0...n*n]
    neighbors.push find_neighbors(pos)
  neighbors

show_queens = (queens, n) ->
  # precondition: queens is a sorted array of integers,
  # and each row is represented
  console.log "\n------"
  for q in queens
    col = q % n
    s = ''
    for c in [0...n]
      if c == col
        s += "Q "
      else
        s += "* "
    console.log s + "\n"

nqueens(8)


(defun queens (n &optional (m n))
  (if (zerop n)
      (list nil)
      (loop for solution in (queens (1- n) m)
            nconc (loop for new-col from 1 to m
                         when (loop for row from 1 to n
                                     for col in solution
                                     always (/= new-col col (+ col row) (- col row)))
                         collect (cons new-col solution)))))

(defun print-solution (solution)
  (loop for queen-col in solution
        do (loop for col from 1 to (length solution)
                  do (write-char (if (= col queen-col) #\Q #\.)))
           (terpri))
  (terpri))

(defun print-queens (n)
  (mapc #'print-solution (queens n)))


-- 8-queens implementation with the Constrained Constructor pattern
-- Sergio Antoy
-- Fri Jul 13 07:05:32 PDT 2001

-- Place 8 queens on a chessboard so that no queen can capture
-- (and be captured by) any other queen.

-- Non-deterministic choice operator

infixl 0 !
X ! _ = X
_ ! Y = Y

-- A solution is represented by a list of integers.
-- The i-th integer in the list is the column of the board
-- in which the queen in the i-th row is placed.
-- Rows and columns are numbered from 1 to 8.
-- For example, [4,2,7,3,6,8,5,1] is a solution where the
-- the queen in row 1 is in column 4, etc.
-- Any solution must be a permutation of [1,2,...,8].

-- The state of a queen is its position, row and column, on the board.
-- Operation column is a particularly simple instance
-- of a Constrained Constructor pattern.
-- When it is invoked, it produces only valid states.

column = 1 ! 2 ! 3 ! 4 ! 5 ! 6 ! 7 ! 8

-- A path of the puzzle is a sequence of successive placements of
-- queens on the board.  It is not explicitly defined as a type.
-- A path is a potential solution in the making.

-- Constrained Constructor on a path
-- Any path must be valid, i.e., any column must be in the range 1..8
-- and different from any other column in the path.
-- Furthermore, the path must be safe for the queens.
-- No queen in a path may capture any other queen in the path.
-- Operation makePath add column n to path c or fails.

makePath c n | valid c && safe c 1 = n:c
    where valid c | n =:= column = uniq c
             where uniq [] = True
                   uniq (c:cs) = n /= c && uniq cs
          safe [] _ = True
          safe (c:cs) k = abs (n-c) /= k && safe cs (k+1)
             where abs x = if x < 0 then -x else x

-- extend the path argument till all the queens are on the board
-- see the Incremental Solution pattern

extend p = if (length p == 8)
             then p
             else extend (makePath p x)
      where x free

-- solve the puzzle

main = extend []


void main() {
    import std.stdio, std.algorithm, std.range, permutations2;

    enum n = 8;
    n.iota.array.permutations.filter!(p =>
        n.iota.map!(i => p[i] + i).array.sort().uniq.count == n &&
        n.iota.map!(i => p[i] - i).array.sort().uniq.count == n)
    .count.writeln;
}


/**
Return true if queen placement q[n] does not conflict with
other queens q[0] through q[n-1]
*/
isConsistent(List q, int n) {
  for (int i=0; i<n; i++) {
    if (q[i] == q[n]) {
      return false; // Same column
    }

    if ((q[i] - q[n]) == (n - i)) {
      return false; // Same major diagonal
    }

    if ((q[n] - q[i]) == (n - i)) {
      return false; // Same minor diagonal
    }
  }

  return true;
}

/**
Print out N-by-N placement of queens from permutation q in ASCII.
*/
printQueens(List q) {
  int N = q.length;
  for (int i=0; i<N; i++) {
    StringBuffer sb = new StringBuffer();
    for (int j=0; j<N; j++) {
      if (q[i] == j) {
        sb.write("Q ");
      } else {
        sb.write("* ");
      }
    }
    print(sb.toString());
  }
  print("");
}

/**
Try all permutations using backtracking
*/
enumerate(int N) {
  var a = new List(N);
  _enumerate(a, 0);
}

_enumerate(List q, int n) {
  if (n == q.length) {
    printQueens(q);
  } else {
    for (int i = 0; i < q.length; i++) {
      q[n] = i;
      if (isConsistent(q, n)){
        _enumerate(q, n+1);
      }
    }
  }
}

void main() {
  enumerate(4);
}


program N_queens_problem;

{$APPTYPE CONSOLE}

uses
  System.SysUtils;

var
  i: Integer;
  q: boolean;
  a: array[0..8] of boolean;
  b: array[0..16] of boolean;
  c: array[0..14] of boolean;
  x: array[0..8] of Integer;

procedure TryMove(i: Integer);
begin
  var j := 1;
  while True do
  begin
    q := false;
    if a[j] and b[i + j] and c[i - j + 7] then
    begin
      x[i] := j;
      a[j] := false;
      b[i + j] := false;
      c[i - j + 7] := false;

      if i < 8 then
      begin
        TryMove(i + 1);
        if not q then
        begin
          a[j] := true;
          b[i + j] := true;
          c[i - j + 7] := true;
        end;
      end
      else
        q := true;
    end;
    if q or (j = 8) then
      Break;
    inc(j);
  end;
end;

begin
  for i := 1 to 8 do
    a[i] := true;

  for i := 2 to 16 do
    b[i] := true;

  for i := 0 to 14 do
    c[i] := true;

  TryMove(1);

  if q then
    for i := 1 to 8 do
      writeln(i, ' ', x[i]);
  readln;
end.


byte SIZE = 8;
word count;

proc solve([*] int hist; int col) void:
    int i, j, n;
    n := dim(hist, 1);
    if col = n then
        count := count + 1;
        writeln();
        writeln("No. ", count);
        writeln("-----");
        for i from 0 upto n-1 do
            for j from 0 upto n-1 do
                write(if j=hist[i] then 'Q'
                      elif (i+j)&1 /= 0 then ' '
                      else '.' fi)
            od;
            writeln()
        od
    else
        for i from 0 upto n-1 do
            j := 0;
            while j<col and not (hist[j]=i or |(hist[j]-i) = col-j) do
                j := j + 1
            od;
            if j >= col then
                hist[col] := i;
                solve(hist, col+1)
            fi
        od
    fi
corp

proc nonrec main() void:
    [SIZE] int hist;
    count := 0;
    solve(hist, 0)
corp


subr show_sol
  print "Solution " & n_sol
  print ""
  for i range n
    write "  "
    for j range n
      if j = x[i]
        write "Q "
      else
        write ". "
      .
    .
    print ""
  .
  print ""
.
subr test
  ok = 1
  for i range y
    if x[y] = x[i] or abs (x[i] - x[y]) = abs (y - i)
      ok = 0
    .
  .
.
n = 8
len x[] n
y = 0
x[0] = 0
while y >= 0
  call test
  if ok = 1 and y + 1 <> n
    y += 1
    x[y] = 0
  else
    if ok = 1
      n_sol += 1
      if n_sol <= 1
        call show_sol
      .
    .
    while y >= 0 and x[y] = n - 1
      y -= 1
    .
    if y >= 0
      x[y] += 1
    .
  .
.
print n_sol & " solutions"


;; square num is i + j*N
(define-syntax-rule (sq i j) (+ i (* j N)))

;; compute diag number for each square
(define (do-diag1 i0 j0  dnum  into: dnum1 N) ;; ++i and ++j diags
	(for [(i (in-range i0 N)) (j (in-range j0 N))]
		;;(writeln   i j 'diag1 dnum)
		(vector-set! dnum1 (sq i j) dnum)))

(define (do-diag2 i0 j0  dnum into: dnum2 N) ;; --i and ++j diags
	(for [(i (in-range i0 -1 -1)) (j (in-range j0 N))]
		;; (writeln i j 'diag2 dnum)
		(vector-set! dnum2 (sq i j) dnum)))

(define (init-diags dnum1 dnum2 N)
	(define dnum 0)
		(for ((j N)) (do-diag1 0 j dnum dnum1 N) (++ dnum))
		(for ((i (in-range 1 N)))
                     (do-diag1 i 0 dnum dnum1  N) (++ dnum))
	(set! dnum 0)
		(for ((j N)) (do-diag2 (1- N) j dnum dnum2 N) (++ dnum))
		(for ((i (1- N))) (do-diag2 i 0 dnum dnum2 N) (++ dnum)))
;; end boring diags part

(define (q-search i  N col diag1 diag2 dnum1 dnum2    &hits (ns))
(cond
[(= i N)  (set-box! &hits (1+ (unbox &hits))) ] ;;  (writeln  'HIT col)
	[else

		(for ((j N))
		(set! ns (sq i j))
		#:continue (or [col j] [diag1 [dnum1 ns]] [diag2 [dnum2 ns]])
		     (vector-set! col j i) ;; move
		     (vector-set! diag1 [dnum1 ns] #t) ;; flag busy diagonal
			(vector-set! diag2 [dnum2 ns] #t)
			(q-search (1+ i) N col diag1 diag2 dnum1 dnum2 &hits)
			(vector-set! col j #f) ;; unmove
			(vector-set! diag1 [dnum1 ns] #f)
			(vector-set! diag2 [dnum2 ns] #f))
			]))

(define (q-count (N 8))
	(define dnum1 (make-vector (* N N)))
	(define dnum2 (make-vector (* N N )))
	(init-diags dnum1 dnum2 N)

	(define diag1 (make-vector (* 2 N) #f)) ; busy diag's
	(define diag2 (make-vector (* 2 N) #f))
	(define col (make-vector N  #f))
	(define &hits (box 0))

	(q-search 0 N col diag1 diag2 dnum1 dnum2  &hits)
	(unbox &hits))

(define (task up-to-n)
	(for ((i up-to-n)) (writeln i ' ♕ (q-count i) 'solutions)))


class
	QUEENS

create
	make

feature {NONE}
	counter: INTEGER

	place_queens(board: ARRAY[INTEGER]; level: INTEGER)
		local
			i, j: INTEGER
			safe: BOOLEAN
		do
			if level > board.count
			then
				counter := counter + 1
			else
				from
					i := 1
				until
					i > board.count
				loop
					safe := True
					from
						j := 1
					until
						j = level or not safe
					loop
						if (board[j] = i)
							or (j - level = i - board[j])
							or (j - level = board[j] - i)
						then
							safe := False
						end
						j := j + 1
					end
					if safe
					then
						board[level] := i
						place_queens(board, level + 1)
					end
					i := i + 1
				end
			end
		end

feature
	possible_positions_of_n_queens(n: INTEGER): INTEGER
		local
			board: ARRAY[INTEGER]
		do
			create board.make_filled (0, 1, n)
			counter := 0
			place_queens(board, 1)
			Result := counter
		end

	make
		local
			n: INTEGER
		do
			io.put_string ("Please enter the number of queens: ")
			io.read_integer
			n := io.last_integer
			print("%NPossible number of placings: " + possible_positions_of_n_queens(n).out + "%N")
		end
end


defmodule RC do
  def queen(n, display \\ true) do
    solve(n, [], [], [], display)
  end

  defp solve(n, row, _, _, display) when n==length(row) do
    if display, do: print(n,row)
    1
  end
  defp solve(n, row, add_list, sub_list, display) do
    Enum.map(Enum.to_list(0..n-1) -- row, fn x ->
      add = x + length(row)             # \ diagonal check
      sub = x - length(row)             # / diagonal check
      if (add in add_list) or (sub in sub_list) do
        0
      else
        solve(n, [x|row], [add | add_list], [sub | sub_list], display)
      end
    end) |> Enum.sum                    # total of the solution
  end

  defp print(n, row) do
    IO.puts frame = "+" <> String.duplicate("-", 2*n+1) <> "+"
    Enum.each(row, fn x ->
      line = Enum.map_join(0..n-1, fn i -> if x==i, do: "Q ", else: ". " end)
      IO.puts "| #{line}|"
    end)
    IO.puts frame
  end
end

Enum.each(1..6, fn n ->
  IO.puts " #{n} Queen : #{RC.queen(n)}"
end)

Enum.each(7..12, fn n ->
  IO.puts " #{n} Queen : #{RC.queen(n, false)}"             # no display
end)


-module( n_queens ).

-export( [display/1, solve/1, task/0] ).

display( Board ) ->
	%% Queens are in the positions in the Board list.
	%% Top left corner is {1, 1}, Bottom right is {N, N}. There is a queen in the max column.
	N = lists:max( [X || {X, _Y} <- Board] ),
	[display_row(Y, N, Board) || Y <- lists:seq(1, N)].

solve( N ) ->
    Positions = [{X, Y} || X <- lists:seq(1, N), Y <- lists:seq(1, N)],
    try
    bt( N, Positions, [] )

    catch
    _:{ok, Board} -> Board

    end.

task() ->
    task( 4 ),
    task( 8 ).

bt( N, Positions, Board ) -> bt_reject( is_not_allowed_queen_placement(N, Board), N, Positions, Board ).

bt_accept( true, _N, _Positions, Board ) -> erlang:throw( {ok, Board} );
bt_accept( false, N, Positions, Board ) -> bt_loop( N, Positions, [], Board ).

bt_loop( _N, [], _Rejects, _Board ) -> failed;
bt_loop( N, [Position | T], Rejects, Board ) ->
	bt( N, T ++ Rejects, [Position | Board] ),
	bt_loop( N, T, [Position | Rejects], Board ).

bt_reject( true, _N, _Positions, _Board ) -> backtrack;
bt_reject( false, N, Positions, Board ) -> bt_accept( is_all_queens(N, Board), N, Positions, Board ).

diagonals( N, {X, Y} ) ->
	D1 = diagonals( N, X + 1, fun diagonals_add1/1, Y + 1, fun diagonals_add1/1 ),
	D2 = diagonals( N, X + 1, fun diagonals_add1/1, Y - 1, fun diagonals_subtract1/1 ),
	D3 = diagonals( N, X - 1, fun diagonals_subtract1/1, Y + 1, fun diagonals_add1/1 ),
	D4 = diagonals( N, X - 1, fun diagonals_subtract1/1, Y - 1, fun diagonals_subtract1/1 ),
	D1 ++ D2 ++ D3 ++ D4.

diagonals( _N, 0, _Change_x, _Y, _Change_y ) -> [];
diagonals( _N, _X, _Change_x, 0, _Change_y ) -> [];
diagonals( N, X, _Change_x, _Y, _Change_y ) when X > N -> [];
diagonals( N, _X, _Change_x, Y, _Change_y ) when Y > N -> [];
diagonals( N, X, Change_x, Y, Change_y ) -> [{X, Y} | diagonals( N, Change_x(X), Change_x, Change_y(Y), Change_y )].

diagonals_add1( N ) -> N + 1.

diagonals_subtract1( N ) -> N - 1.

display_row( Row, N, Board ) ->
	[io:fwrite("~s", [display_queen(X, Row, Board)]) || X <- lists:seq(1, N)],
	io:nl().

display_queen( X, Y, Board ) -> display_queen( lists:member({X, Y}, Board) ).
display_queen( true ) -> " Q";
display_queen( false ) -> " .".

is_all_queens( N, Board ) -> N =:= erlang:length( Board ).

is_diagonal( _N, [] ) -> false;
is_diagonal( N, [Position | T] ) ->
	Diagonals = diagonals( N, Position ),
	T =/= (T -- Diagonals)
	orelse is_diagonal( N, T ).

is_not_allowed_queen_placement( N, Board ) ->
	Pieces = erlang:length( Board ),
	{Xs, Ys} = lists:unzip( Board ),
	Pieces =/= erlang:length( lists:usort(Xs) )
	orelse Pieces =/= erlang:length( lists:usort(Ys) )
	orelse is_diagonal( N, Board ).

task( N ) ->
    io:fwrite( "N = ~p. One solution.~n", [N] ),
    Board = solve( N ),
    display( Board ).


BEGIN

    # This is a translation of the Javascript sample, main differences are because Algol 68    #
    # is strongly typed and "on-the-fly" constructon of functions is not really possible -     #
    # we need to define a STRUCT where Javascript would just construct a new function.         #
    # As Algol 68 does not allow procedure overloading, we use custom operators (which do      #
    # allow overloading) so the techniques used here could be extended to procedures with      #
    # signatures other than PROC(REAL)REAL                                                     #
    # The comments are generally the same as in the javascript original, changed as necessary  #
    # to reflect Algol 68...                                                                   #

    # START WITH SOME SIMPLE (UNSAFE) PARTIAL FUNCTIONS:                                       #

    # error in n < 0 #
    PROC unsafe reciprocal = (REAL n)REAL: 1 / n;
    # error if n < 0 #
    PROC unsafe root       = (REAL n)REAL: sqrt(n);
    # error if n <= 0 #
    PROC unsafe log        = (REAL n)REAL: ln(n);

    # NOW DERIVE SAFE VERSIONS OF THESE SIMPLE FUNCTIONS:                                      #
    # These versions use a validity test, and return a wrapped value                           #
    # with a boolean is valid property as well as a value property                             #

    MODE SAFEFUNCTION = STRUCT( PROC(REAL)REAL fn, PROC(REAL)BOOL fn safety check );
    MODE MAYBE        = STRUCT( BOOL is valid, REAL value );

    SAFEFUNCTION safe reciprocal = ( unsafe reciprocal, ( REAL n )BOOL: n /= 0 );
    SAFEFUNCTION safe root       = ( unsafe root,       ( REAL n )BOOL: n >= 0 );
    SAFEFUNCTION safe log        = ( unsafe log,        ( REAL n )BOOL: n >  0 );

COMMENT
    the original Javascript contains this:

    // THE DERIVATION OF THE SAFE VERSIONS USED THE 'UNIT' OR 'RETURN'
    // FUNCTION OF THE MAYBE MONAD

    // Named maybe() here, the unit function of the Maybe monad wraps a raw value
    // in a datatype with two elements: .isValid (Bool) and .value (Number)

    // a -> Ma
    function maybe(n) {
        return {
            isValid: (typeof n !== 'undefined'),
            value: n
        };
    }

    However Algol 68 is strongly typed, so the type (MODE) of the function parameters
    cannot be anything other than REAL. We therefore use "MAYBE( TRUE, n )" instead.
COMMENT

    # THE PROBLEM FOR FUNCTION NESTING (COMPOSITION) OF THE SAFE FUNCTIONS                     #
    # IS THAT THEIR INPUT AND OUTPUT TYPES ARE DIFFERENT                                       #

    # Our safe versions of the functions take simple numeric arguments (i.e. REAL), but return #
    # wrapped results. If we feed a wrapped result as an input to another safe function, the   #
    # compiler will object. The solution is to write a higher order                            #
    # function (sometimes called 'bind' or 'chain') which handles composition, taking a        #
    # a safe function and a wrapped value as arguments,                                        #

    # The 'bind' function of the Maybe monad:                                                  #
    # 1. Applies a 'safe' function directly to the raw unwrapped value, and                    #
    # 2. returns the wrapped result.                                                           #

    # Ma -> (a -> Mb) -> Mb #
    # defined as an operator to allow overloading to other PROC modes                          #
    PRIO BIND = 1;
    OP   BIND = (MAYBE maybe n, SAFEFUNCTION mf )MAYBE:
        IF is valid OF maybe n THEN mf CALL ( value OF maybe n ) ELSE maybe n FI;
    # we need an operator to call the wrapped function                                         #
    PRIO CALL = 1;
    OP   CALL = ( SAFEFUNCTION f, REAL value )MAYBE:
         BEGIN
             BOOL is valid = ( fn safety check OF f )( value );
             MAYBE( is valid, IF is valid THEN ( fn OF f )( value ) ELSE value FI )
         END; # CALL #

    # Using the bind function, we can nest applications of safe functions,                     #
    # without the compiler choking on unexpectedly wrapped values returned from                #
    # other functions of the same kind.                                                        #
    REAL root one over four = value OF ( MAYBE( TRUE, 4 ) BIND safe reciprocal BIND safe root );

#   print( ( root one over four, newline ) ); #
    # -> 0.5 #

    # We can compose a chain of safe functions (of any length) with a simple foldr/reduceRight #
    # which starts by 'lifting' the numeric argument into a Maybe wrapping,                    #
    # and then nests function applications (working from right to left)                        #
    # again, defined as an operator here to allow extension to other PROC modes                #
    # also, as Algol 68 doesn't have builtin foldr/reduceRight, we need a loop...              #
    PRIO SAFECOMPOSE = 1;
    OP   SAFECOMPOSE = ( []SAFEFUNCTION lst functions, REAL value )MAYBE:
         BEGIN
             MAYBE result := MAYBE( TRUE, value );
             FOR fn pos FROM UPB lst functions BY -1 TO LWB lst functions DO
                 result := result BIND lst functions[ fn pos ]
             OD;
             result
         END; # SAFECOMPOSE #

    # TEST INPUT VALUES WITH A SAFELY COMPOSED VERSION OF LOG(SQRT(1/X))                       #

    PROC safe log root reciprocal = ( REAL n )MAYBE:
         BEGIN
             # this declaration is requied for Algol 68G 2.8                                   #
             []SAFEFUNCTION function list = ( safe log, safe root, safe reciprocal );
             function list SAFECOMPOSE n
         END; # safe log root reciprocal #

    # Algol 68 doesn't have a builtin map operator, we could define one here but we can just   #
    # use a loop for the purposes of this task...                                              #
    REAL e = exp( 1 );
    []REAL test values = ( -2, -1, -0.5, 0, 1 / e, 1, 2, e, 3, 4, 5 );

    STRING prefix := "[";
    FOR test pos FROM LWB test values TO UPB test values DO
        MAYBE result = safe log root reciprocal( test values[ test pos ] );
        print( ( prefix, IF is valid OF result THEN fixed( value OF result, -12, 8 ) ELSE "undefined" FI ) );
        IF test pos MOD 4 = 0 THEN print( ( newline ) ) FI;
        prefix := ", "
    OD;
    print( ( "]", newline ) )

END


!------------------------------------------------
! QUEENS.R : solve queens problem on a NxN board
!------------------------------------------------

PROGRAM QUEENS

DIM COL%[15]

BEGIN
  MAXSIZE%=15
  PRINT(TAB(25);" --- PROBLEMA DELLE REGINE --- ")
  PRINT
  PRINT("Board dimension ";)
  INPUT(N%)
  PRINT
  IF (N%<1 OR N%>MAXSIZE%)
    THEN
      PRINT("Illegal dimension!!")
    ELSE
      FOR CURCOLNBR%=1 TO N%
        COL%[CURCOLNBR%]=0
      END FOR
      CURCOLNBR%=1
      WHILE CURCOLNBR%>0 DO
        PLACEDAQUEEN%=FALSE
        I%=COL%[CURCOLNBR%]+1
        WHILE (I%<=N%) AND NOT PLACEDAQUEEN% DO
          PLACEDAQUEEN%=TRUE
          J%=1
          WHILE PLACEDAQUEEN% AND (J%<CURCOLNBR%) DO
            PLACEDAQUEEN%=COL%[J%]<>I%
            J%=J%+1
          END WHILE
          IF PLACEDAQUEEN%
            THEN
              DIAGNBR%=I%+CURCOLNBR%
              J%=1
              WHILE PLACEDAQUEEN% AND (J%<CURCOLNBR%) DO
                PLACEDAQUEEN%=(COL%[J%]+J%)<>DIAGNBR%
                J%=J%+1
              END WHILE
            ELSE
          END IF
          IF PLACEDAQUEEN%
            THEN
              DIAGNBR%=I%-CURCOLNBR%
              J%=1
              WHILE PLACEDAQUEEN% AND (J%<CURCOLNBR%) DO
                 PLACEDAQUEEN%=(COL%[J%]-J%)<>DIAGNBR%
                 J%=J%+1
              END WHILE
            ELSE
          END IF
          IF NOT PLACEDAQUEEN%
            THEN
              I%=I%+1
            ELSE
              COL%[CURCOLNBR%]=I%
          END IF
        END WHILE
        IF NOT PLACEDAQUEEN%
          THEN
            COL%[CURCOLNBR%]=0
            CURCOLNBR%=CURCOLNBR%-1
          ELSE
            IF CURCOLNBR%=N%
              THEN
                NSOL%=NSOL%+1
                PRINT("Soluzione";NSOL%;":";)
                FOR I%=1 TO N%
                  PRINT(COL%[I%];)
                END FOR
                PRINT
              ELSE
                CURCOLNBR%=CURCOLNBR%+1
            END IF
        END IF
      END WHILE
      PRINT("Search completed")
      REPEAT
         GET(CH$)
      UNTIL CH$<>""
    END IF
END PROGRAM


property e : 2.71828182846

on run {}

    -- Derive safe versions of three simple functions
    set sfReciprocal to safeVersion(reciprocal, notZero)
    set sfRoot to safeVersion(root, isPositive)
    set sfLog to safeVersion(ln, aboveZero)

    -- Test a composition of these function with a range of invalid and valid arguments

    -- (The safe composition returns missing value (without error) for invalid arguments)

    map([-2, -1, -0.5, 0, 1 / e, 1, 2, e, 3, 4, 5], safeLogRootReciprocal)

    -- 'missing value' is returned by a safe function (and threaded up through the monad) when the input argument is out of range
    --> {missing value, missing value, missing value, missing value, 0.5, 0.0, -0.346573590279, -0.499999999999, -0.549306144333, -0.69314718056, -0.804718956217}
end run

-- START WITH SOME SIMPLE (UNSAFE) PARTIAL FUNCTIONS:

-- Returns ERROR 'Script Error: Can’t divide 1.0 by zero.' if n = 0
on reciprocal(n)
    1 / n
end reciprocal

-- Returns ERROR 'error "The result of a numeric operation was too large." number -2702'
-- for all values below 0
on root(n)
    n ^ (1 / 2)
end root

-- Returns -1.0E+20 for all values of zero and below
on ln(n)
    (do shell script ("echo 'l(" & (n as string) & ")' | bc -l")) as real
end ln

-- DERIVE A SAFE VERSION OF EACH FUNCTION
-- (SEE on Run() handler)

on safeVersion(f, fnSafetyCheck)
    script
        on call(x)
            if sReturn(fnSafetyCheck)'s call(x) then
                sReturn(f)'s call(x)
            else
                missing value
            end if
        end call
    end script
end safeVersion

on notZero(n)
    n is not 0
end notZero

on isPositive(n)
    n ≥ 0
end isPositive

on aboveZero(n)
    n > 0
end aboveZero

-- DEFINE A FUNCTION WHICH CALLS A COMPOSITION OF THE SAFE VERSIONS
on safeLogRootReciprocal(x)

    value of mbCompose([my sfLog, my sfRoot, my sfReciprocal], x)

end safeLogRootReciprocal

-- UNIT/RETURN and BIND functions for the Maybe monad

-- Unit / Return for maybe
on maybe(n)
    {isValid:n is not missing value, value:n}
end maybe

-- BIND maybe
on mbBind(recMaybe, mfSafe)
    if isValid of recMaybe then
        maybe(mfSafe's call(value of recMaybe))
    else
        recMaybe
    end if
end mbBind

-- lift 2nd class function into 1st class wrapper
-- handler function --> first class script object
on sReturn(f)
    script
        property call : f
    end script
end sReturn

-- return a new script in which function g is composed
-- with the f (call()) of the Mf script
-- Mf -> (f -> Mg) -> Mg
on sBind(mf, g)
    script
        on call(x)
            sReturn(g)'s call(mf's call(x))
        end call
    end script
end sBind

on mbCompose(lstFunctions, value)
    reduceRight(lstFunctions, mbBind, maybe(value))
end mbCompose

-- xs: list, f: function, a: initial accumulator value
-- the arguments available to the function f(a, x, i, l) are
-- v: current accumulator value
-- x: current item in list
-- i: [ 1-based index in list ] optional
-- l: [ a reference to the list itself ] optional
on reduceRight(xs, f, a)
    set mf to sReturn(f)

    repeat with i from length of xs to 1 by -1
        set a to mf's call(a, item i of xs, i, xs)
    end repeat
end reduceRight

-- [a] -> (a -> b) -> [b]
on map(xs, f)
    set mf to sReturn(f)
    set lst to {}
    set lng to length of xs
    repeat with i from 1 to lng
        set end of lst to mf's call(item i of xs, i, xs)
    end repeat
    return lst
end map


let rec iterate f value = seq {
    yield value
    yield! iterate f (f value) }

let up i = i + 1
let right i = i
let down i = i - 1

let noCollisionGivenDir solution number dir =
    Seq.forall2 (<>) solution (Seq.skip 1 (iterate dir number))

let goodAddition solution number =
    List.forall (noCollisionGivenDir solution number) [ up; right; down ]

let rec extendSolution n ps =
    [0..n - 1]
    |> List.filter (goodAddition ps)
    |> List.map (fun num -> num :: ps)

let allSolutions n =
    iterate (List.collect (extendSolution n)) [[]]

// Print one solution for the 8x8 case
let printOneSolution () =
    allSolutions 8
    |> Seq.item 8
    |> Seq.head
    |> List.iter (fun rowIndex ->
        printf "|"
        [0..8] |> List.iter (fun i -> printf (if i = rowIndex then "X|" else " |"))
        printfn "")

// Print number of solution for the other cases
let printNumberOfSolutions () =
    printfn "Size\tNr of solutions"
    [1..11]
    |> List.map ((fun i -> Seq.item i (allSolutions i)) >> List.length)
    |> List.iteri (fun i cnt -> printfn "%d\t%d" (i+1) cnt)

printOneSolution()

printNumberOfSolutions()


#include <stdio.h>
#include <stdlib.h>
#include <stdbool.h>

typedef enum type
{
  INT,
  STRING
} Type;

typedef struct maybe
{
  int i;
  char *s;
  Type t;
  _Bool is_something;
} Maybe;

void print_Maybe(Maybe *m)
{
  if (m->t == INT)
    printf("Just %d : INT\n", m->i);

  else if (m->t == STRING)
    printf("Just \"%s\" : STRING\n", m->s);

  else
    printf("Nothing\n");

}

Maybe *return_maybe(void *data, Type t)
{
  Maybe *m = malloc(sizeof(Maybe));
  if (t == INT)
  {
    m->i = *(int *) data;
    m->s = NULL;
    m->t = INT;
    m->is_something = true;
  }

  else if (t == STRING)
  {
    m->i = 0;
    m->s = data;
    m->t = STRING;
    m->is_something = true;
  }

  else
  {
    m->i = 0;
    m->s = NULL;
    m->t = 0;
    m->is_something = false;
  }

  return m;
}

Maybe *bind_maybe(Maybe *m, Maybe *(*f)(void *))
{
  Maybe *n = malloc(sizeof(Maybe));

  if (f(&(m->i))->is_something)
  {
    n->i = f(&(m->i))->i;
    n->s = f(&(m->i))->s;
    n->t = f(&(m->i))->t;
    n->is_something = true;
  }

  else
  {
    n->i = 0;
    n->s = NULL;
    n->t = 0;
    n->is_something = false;
  }
  return n;
}

Maybe *f_1(void *v) // Int -> Maybe Int
{
  Maybe *m = malloc(sizeof(Maybe));
  m->i = (*(int *) v) * (*(int *) v);
  m->s = NULL;
  m->t = INT;
  m->is_something = true;
  return m;
}

Maybe *f_2(void *v) // :: Int -> Maybe String
{
  Maybe *m = malloc(sizeof(Maybe));
  m->i = 0;
  m->s = malloc(*(int *) v * sizeof(char) + 1);
  for (int i = 0; i < *(int *) v; i++)
  {
    m->s[i] = 'x';
  }
  m->s[*(int *) v + 1] = '\0';
  m->t = STRING;
  m->is_something = true;
  return m;
}

int main()
{
  int i = 7;
  char *s = "lorem ipsum dolor sit amet";

  Maybe *m_1 = return_maybe(&i, INT);
  Maybe *m_2 = return_maybe(s, STRING);

  print_Maybe(m_1); // print value of m_1: Just 49
  print_Maybe(m_2); // print value of m_2 : Just "lorem ipsum dolor sit amet"

  print_Maybe(bind_maybe(m_1, f_1)); // m_1 `bind` f_1 :: Maybe Int
  print_Maybe(bind_maybe(m_1, f_2)); // m_1 `bind` f_2 :: Maybe String

  print_Maybe(bind_maybe(bind_maybe(m_1, f_1), f_2)); // (m_1 `bind` f_1) `bind` f_2 :: Maybe String -- it prints 49 'x' characters in a row
}


USING: kernel sequences math math.combinatorics formatting io locals ;
IN: queens

: /=  ( x y -- ? )   = not ; inline

:: safe?  ( board q -- ? )
    [let  q board nth :> x
      q <iota> [
         x swap
         [ board nth ] keep
         q swap -
           [ + /= ]
           [ - /= ] 3bi and
      ] all?
    ] ;

: solution? ( board -- ? )
    dup length <iota> [ dupd safe? ] all? nip ;

: queens ( n -- l )
    <iota> all-permutations [ solution? ] filter ;

: .queens ( n -- )
    queens
    [
      [ 1 + "%d " printf ] each nl
    ] each ;


#include <iostream>
#include <cmath>
#include <optional>
#include <vector>

using namespace std;

// std::optional can be a maybe monad.  Use the >> operator as the bind function
template <typename T>
auto operator>>(const optional<T>& monad, auto f)
{
    if(!monad.has_value())
    {
        // Return an empty maybe monad of the same type as if there
        // was a value
        return optional<remove_reference_t<decltype(*f(*monad))>>();
    }

    return f(*monad);
}

// The Pure function returns a maybe monad containing the value t
auto Pure(auto t)
{
    return optional{t};
}

// A safe function to invert a value
auto SafeInverse(double v)
{
    if (v == 0)
    {
        return optional<decltype(v)>();
    }
    else
    {
        return optional(1/v);
    }
}

// A safe function to calculate the arc cosine
auto SafeAcos(double v)
{
    if(v < -1 || v > 1)
    {
        // The input is out of range, return an empty monad
        return optional<decltype(acos(v))>();
    }
    else
    {
        return optional(acos(v));
    }
}

// Print the monad
template<typename T>
ostream& operator<<(ostream& s, optional<T> v)
{
    s << (v ? to_string(*v) : "nothing");
    return s;
}

int main()
{
    // Use bind to compose SafeInverse and SafeAcos
    vector<double> tests {-2.5, -1, -0.5, 0, 0.5, 1, 2.5};

    cout << "x -> acos(1/x) , 1/(acos(x)\n";
    for(auto v : tests)
    {
        auto maybeMonad = Pure(v);
        auto inverseAcos = maybeMonad >> SafeInverse >> SafeAcos;
        auto acosInverse = maybeMonad >> SafeAcos >> SafeInverse;
        cout << v << " -> " << inverseAcos << ", " << acosInverse << "\n";
    }
}


variable solutions
variable nodes

: bits ( n -- mask ) 1 swap lshift 1- ;
: lowBit  ( mask -- bit ) dup negate and ;
: lowBit- ( mask -- bits ) dup 1- and ;

: next3 ( dl dr f files -- dl dr f dl' dr' f' )
  invert >r
  2 pick [email protected] and 2* 1+
  2 pick [email protected] and 2/
  2 pick r> and ;

: try ( dl dr f -- )
  dup if
    1 nodes +!
    dup 2over and and
    begin ?dup while
      dup >r lowBit next3 recurse r> lowBit-
    repeat
  else 1 solutions +! then
  drop 2drop ;

: queens ( n -- )
  0 solutions ! 0 nodes !
  -1 -1 rot bits try
  solutions @ . ." solutions, " nodes @ . ." nodes" ;

8 queens  \ 92 solutions, 1965 nodes


using System;

namespace RosettaMaybe
{
    // courtesy of https://www.dotnetcurry.com/patterns-practices/1510/maybe-monad-csharp
    public abstract class Maybe<T>
    {
        public sealed class Some : Maybe<T>
        {
            public Some(T value) => Value = value;
            public T Value { get; }
        }
        public sealed class None : Maybe<T> { }
    }

    class Program
    {
        static Maybe<double> MonadicSquareRoot(double x)
        {
            if (x >= 0)
            {
                return new Maybe<double>.Some(Math.Sqrt(x));
            }
            else
            {
                return new Maybe<double>.None();
            }
        }
        static void Main(string[] args)
        {
            foreach (double x in new double[] { 4.0D, 8.0D, -15.0D, 16.23D, -42 })
            {
                Maybe<double> maybe = MonadicSquareRoot(x);
                if (maybe is Maybe<double>.Some some)
                {
                    Console.WriteLine($"The square root of {x} is " + some.Value);
                }
                else
                {
                    Console.WriteLine($"Square root of {x} is undefined.");
                }
            }
        }
    }
}


(defn bind [val f]
  (if-let [v (:value val)] (f v) val))

(defn unit [val] {:value val})

(defn opt_add_3 [n] (unit (+ 3 n))) ; takes a number and returns a Maybe number
(defn opt_str [n] (unit (str n)))   ; takes a number and returns a Maybe string

(bind (unit 4) opt_add_3)                  ; evaluates to {:value 7}
(bind (unit nil) opt_add_3)                ; evaluates to {:value nil}
(bind (bind (unit 8) opt_add_3) opt_str)   ; evaluates to {:value "11"}
(bind (bind (unit nil) opt_add_3) opt_str) ; evaluates to {:value nil}


program Nqueens
  implicit none

  integer, parameter :: n = 8  ! size of board
  integer :: file = 1, rank = 1, queens = 0
  integer :: i
  logical :: board(n,n) = .false.

  do while (queens < n)
    board(file, rank) = .true.
    if(is_safe(board, file, rank)) then
      queens = queens + 1
      file = 1
      rank = rank + 1
    else
      board(file, rank) = .false.
      file = file + 1
      do while(file > n)
         rank = rank - 1
         if (rank < 1) then
           write(*, "(a,i0)") "No solution for n = ", n
           stop
         end if
         do i = 1, n
           if (board(i, rank)) then
             file = i
             board(file, rank) = .false.
             queens = queens - 1
             file = i + 1
             exit
           end if
         end do
       end do
    end if
  end do

  call Printboard(board)

contains

function is_safe(board, file, rank)
  logical :: is_safe
  logical, intent(in) :: board(:,:)
  integer, intent(in) :: file, rank
  integer :: i, f, r

  is_safe = .true.
  do i = rank-1, 1, -1
    if(board(file, i)) then
      is_safe = .false.
      return
    end if
  end do

  f = file - 1
  r = rank - 1
  do while(f > 0 .and. r > 0)
    if(board(f, r)) then
      is_safe = .false.
      return
    end if
    f = f - 1
    r = r - 1
  end do

  f = file + 1
  r = rank - 1
  do while(f <= n .and. r > 0)
    if(board(f, r)) then
      is_safe = .false.
      return
    end if
    f = f + 1
    r = r - 1
  end do
end function

subroutine Printboard(board)
  logical, intent(in) :: board(:,:)
  character(n*4+1) :: line
  integer :: f, r

  write(*, "(a, i0)") "n = ", n
  line = repeat("+---", n) // "+"
  do r = 1, n
    write(*, "(a)") line
    do f = 1, n
      write(*, "(a)", advance="no") "|"
      if(board(f, r)) then
        write(*, "(a)", advance="no") " Q "
      else if(mod(f+r, 2) == 0) then
        write(*, "(a)", advance="no") "   "
      else
        write(*, "(a)", advance="no") "###"
      end if
    end do
    write(*, "(a)") "|"
  end do
  write(*, "(a)") line
end subroutine
end program


program Maybe_monad;

{$APPTYPE CONSOLE}

uses
  System.SysUtils;

type
  TmList = record
    Value: PInteger;
    function ToString: string;
    function Bind(f: TFunc<PInteger, TmList>): TmList;
  end;

function _Unit(aValue: Integer): TmList; overload;
begin
  Result.Value := GetMemory(sizeof(Integer));
  Result.Value^ := aValue;
end;

function _Unit(aValue: PInteger): TmList; overload;
begin
  Result.Value := aValue;
end;

{ TmList }

function TmList.Bind(f: TFunc<PInteger, TmList>): TmList;
begin
  Result := f(self.Value);
end;

function TmList.ToString: string;
begin
  if Value = nil then
    Result := 'none'
  else
    Result := value^.ToString;
end;

function Decrement(p: PInteger): TmList;
begin
  if p = nil then
    exit(_Unit(nil));
  Result := _Unit(p^ - 1);
end;

function Triple(p: PInteger): TmList;
begin
  if p = nil then
    exit(_Unit(nil));
  Result := _Unit(p^ * 3);
end;

var
  m1, m2: TmList;
  i, a, b, c: Integer;
  p: Tarray<PInteger>;

begin
  a := 3;
  b := 4;
  c := 5;
  p := [@a, @b, nil, @c];

  for i := 0 to High(p) do
  begin
    m1 := _Unit(p[i]);
    m2 := m1.Bind(Decrement).Bind(Triple);

    Writeln(m1.ToString: 4, ' -> ', m2.ToString);
  end;
  Readln;
end.


' version 13-04-2017
' compile with: fbc -s console
Dim Shared As ULong count, c()

Sub n_queens(row As ULong, n As ULong, show As ULong = 0)

    Dim As ULong x, y

    For x = 1 To n

        For y = 1 To row -1
            If c(y) = x OrElse ((row - y) - Abs(x - c(y))) = 0 Then
                Continue For, For
            End If
        Next

        c(row) = x
        If row < n Then
            n_queens(row +1 , n, show)
        Else
            count += 1

            If show <> 0 Then
                For y = 1 To n
                    Print Using "###"; c(y);
                Next
                Print
            End If

        End If

    Next

End Sub

' ------=< MAIN >=------

Dim As ULong n = 5
ReDim c(n)
' n_queens(1, n, show = 0 only show total | show <> 0 show every solution
n_queens(1, n, 1)
Print Using "## x ## board, ##### solutions"; n; n; count
Print

For n = 1 To 14
    ReDim c(n)
    count = 0
    n_queens(1, n)
    Print Using "A ## x ## board has ######## solutions"; n; n; count
Next

' empty keyboard buffer
While Inkey <> "" : Wend
Print : Print "hit any key to end program"
Sleep
End


(define (Maybe.domain? x) (or (number? x) (string? x)))
(define (Maybe.unit elem (bool #t)) (cons bool elem))

;; f is a safe or unsafe function
;; (Maybe.lift f) returns a safe Maybe function which returns a Maybe element
(define (Maybe.lift f)
		(lambda(x)
             (let [(u (f x))]
             (if (Maybe.domain? u)
                (Maybe.unit u)
                (Maybe.unit x #f))))) ;; return offending x

;; elem = Maybe element
;; f is safe or unsafe  (lisp) function
;; return Maybe element
(define (Maybe.bind f elem)
		(if (first elem) ((Maybe.lift f)  (rest elem)) elem))

;; pretty-print
(define (Maybe.print elem)
		(if (first elem)  (writeln elem ) (writeln '❌ elem)))

;; unsafe functions
(define (u-log x) (if (> x 0) (log x) #f))
(define (u-inv x) (if (zero? x) 'zero-div (/ x)))

;; (print (number->string (exp (log 3))))
(->> 3 Maybe.unit (Maybe.bind u-log) (Maybe.bind exp)  (Maybe.bind number->string) Maybe.print)
    → (#t . "3.0000000000000004")

;; (print (number->string (exp (log -666))))
(->> -666  Maybe.unit (Maybe.bind u-log) (Maybe.bind exp)  (Maybe.bind number->string) Maybe.print)
     → ❌     (#f . -666)

;; ;; (print (number->string (inverse (log 1))))
(->> 1 Maybe.unit (Maybe.bind u-log)  (Maybe.bind u-inv)  (Maybe.bind number->string) Maybe.print)
     →  ❌     (#f . 0)


// We can use Some as return, Option.bind and the pipeline operator in order to have a very concise code

let f1 (v:int) = Some v  // int -> Option<int>
let f2 (v:int) = Some(string v) // int -> Option<sting>

f1 4 |> Option.bind f2 |> printfn "Value is %A"  // bind when option (maybe) has data
None |> Option.bind f2 |> printfn "Value is %A" // bind when option (maybe) does not have data


solution[board] :=
{
    for q = 0 to length[board] - 1
        for c = q+1 to length[board] - 1
            if [email protected] == [email protected] + (c - q) or [email protected] == [email protected] - (c - q)
                return false
    return true
}

for b = array[1 to 8].permute[]
    if solution[b]
        println[b]


USING: monads ;
FROM: monads => do ;

! Prints "T{ just { value 7 } }"
3 maybe-monad return >>= [ 2 * maybe-monad return ] swap call
                     >>= [ 1 + maybe-monad return ] swap call .

! Prints "nothing"
nothing >>= [ 2 * maybe-monad return ] swap call
        >>= [ 1 + maybe-monad return ] swap call .


package main

import (
    "fmt"
    "strconv"
)

type maybe struct{ value *int }

func (m maybe) bind(f func(p *int) maybe) maybe {
    return f(m.value)
}

func unit(p *int) maybe {
    return maybe{p}
}

func decrement(p *int) maybe {
    if p == nil {
        return unit(nil)
    } else {
        q := *p - 1
        return unit(&q)
    }
}

func triple(p *int) maybe {
    if p == nil {
        return unit(nil)
    } else {
        q := (*p) * 3
        return unit(&q)
    }
}

func main() {
    i, j, k := 3, 4, 5
    for _, p := range []*int{&i, &j, nil, &k} {
        m1 := unit(p)
        m2 := m1.bind(decrement).bind(triple)
        var s1, s2 string = "none", "none"
        if m1.value != nil {
            s1 = strconv.Itoa(*m1.value)
        }
        if m2.value != nil {
            s2 = strconv.Itoa(*m2.value)
        }
        fmt.Printf("%4s -> %s\n", s1, s2)
    }
}


NrQueens := function(n)
    local a, up, down, m, sub;
    a := [1 .. n];
    up := ListWithIdenticalEntries(2*n - 1, true);
    down := ListWithIdenticalEntries(2*n - 1, true);
    m := 0;
    sub := function(i)
        local j, k, p, q;
        for k in [i .. n] do
            j := a[k];
            p := i + j - 1;
            q := i - j + n;
            if up[p] and down[q] then
                if i = n then
                    m := m + 1;
                else
                    up[p] := false;
                    down[q] := false;
                    a[k] := a[i];
                    a[i] := j;
                    sub(i + 1);
                    up[p] := true;
                    down[q] := true;
                    a[i] := a[k];
                    a[k] := j;
                fi;
            fi;
        od;
    end;
    sub(1);
    return m;
end;

Queens := function(n)
    local a, up, down, v, sub;
    a := [1 .. n];
    up := ListWithIdenticalEntries(2*n - 1, true);
    down := ListWithIdenticalEntries(2*n - 1, true);
    v := [];
    sub := function(i)
        local j, k, p, q;
        for k in [i .. n] do
            j := a[k];
            p := i + j - 1;
            q := i - j + n;
            if up[p] and down[q] then
                if i = n then
                    Add(v, ShallowCopy(a));
                else
                    up[p] := false;
                    down[q] := false;
                    a[k] := a[i];
                    a[i] := j;
                    sub(i + 1);
                    up[p] := true;
                    down[q] := true;
                    a[i] := a[k];
                    a[k] := j;
                fi;
            fi;
        od;
    end;
    sub(1);
    return v;
end;

NrQueens(8);
a := Queens(8);;
PrintArray(PermutationMat(PermList(a[1]), 8));

[ [  1,  0,  0,  0,  0,  0,  0,  0 ],
  [  0,  0,  0,  0,  1,  0,  0,  0 ],
  [  0,  0,  0,  0,  0,  0,  0,  1 ],
  [  0,  0,  0,  0,  0,  1,  0,  0 ],
  [  0,  0,  1,  0,  0,  0,  0,  0 ],
  [  0,  0,  0,  0,  0,  0,  1,  0 ],
  [  0,  1,  0,  0,  0,  0,  0,  0 ],
  [  0,  0,  0,  1,  0,  0,  0,  0 ] ]


main = do print $ Just 3 >>= (return . (*2)) >>= (return . (+1))  -- prints "Just 7"
          print $ Nothing >>= (return . (*2)) >>= (return . (+1)) -- prints "Nothing"


:-  %say
|=  [^ [[txt=(unit ,@tas) ~] ~]]
:-  %noun
|^
  %+  biff  txt
    ;~  biff
      m-parse
      m-double
    ==
  ++  m-parse
    |=  [email protected]
    ^-  (unit ,@ud)
    (rust (trip a) dem)
  ::
  ++  m-double
    |=  [email protected]
    ^-  (unit ,@ud)
    (some (mul a 2))
  --


NB. monad implementation:
unit=: <
bind=: (@>)( :: ])

NB. monad utility
safeVersion=: (<@) ( ::((<_.)"_))
safeCompose=:dyad define
  dyad def 'x`:6 bind y'/x,unit y
)

NB. unsafe functions (fail with infinite arguments)
subtractFromSelf=: -~
divideBySelf=: %~

NB. wrapped functions:
safeSubtractFromSelf=: subtractFromSelf safeVersion
safeDivideBySelf=: divideBySelf safeVersion

NB. task example:
     safeSubtractFromSelf bind safeDivideBySelf 1
┌─┐
│0│
└─┘
     safeSubtractFromSelf bind safeDivideBySelf _
┌──┐
│_.│
└──┘


(function () {
    'use strict';

    // START WITH SOME SIMPLE (UNSAFE) PARTIAL FUNCTIONS:

    // Returns Infinity if n === 0
    function reciprocal(n) {
        return 1 / n;
    }

    // Returns NaN if n < 0
    function root(n) {
        return Math.sqrt(n);
    }

    // Returns -Infinity if n === 0
    // Returns NaN if n < 0
    function log(n) {
        return Math.log(n);
    }

    // NOW DERIVE SAFE VERSIONS OF THESE SIMPLE FUNCTIONS:
    // These versions use a validity test, and return a wrapped value
    // with a boolean .isValid property as well as a .value property

    function safeVersion(f, fnSafetyCheck) {
        return function (v) {
            return maybe(fnSafetyCheck(v) ? f(v) : undefined);
        }
    }

    var safe_reciprocal = safeVersion(reciprocal, function (n) {
        return n !== 0;
    });

    var safe_root = safeVersion(root, function (n) {
        return n >= 0;
    });

    var safe_log = safeVersion(log, function (n) {
        return n > 0;
    });

    // THE DERIVATION OF THE SAFE VERSIONS USED THE 'UNIT' OR 'RETURN'
    // FUNCTION OF THE MAYBE MONAD

    // Named maybe() here, the unit function of the Maybe monad wraps a raw value
    // in a datatype with two elements: .isValid (Bool) and .value (Number)

    // a -> Ma
    function maybe(n) {
        return {
            isValid: (typeof n !== 'undefined'),
            value: n
        };
    }

    // THE PROBLEM FOR FUNCTION NESTING (COMPOSITION) OF THE SAFE FUNCTIONS
    // IS THAT THEIR INPUT AND OUTPUT TYPES ARE DIFFERENT

    // Our safe versions of the functions take simple numeric arguments, but return
    // wrapped results. If we feed a wrapped result as an input to another safe function,
    // it will choke on the unexpected type. The solution is to write a higher order
    // function (sometimes called 'bind' or 'chain') which handles composition, taking a
    // a safe function and a wrapped value as arguments,

    // The 'bind' function of the Maybe monad:
    // 1. Applies a 'safe' function directly to the raw unwrapped value, and
    // 2. returns the wrapped result.

    // Ma -> (a -> Mb) -> Mb
    function bind(maybeN, mf) {
        return (maybeN.isValid ? mf(maybeN.value) : maybeN);
    }

    // Using the bind function, we can nest applications of safe_ functions,
    // without their choking on unexpectedly wrapped values returned from
    // other functions of the same kind.
    var rootOneOverFour = bind(
        bind(maybe(4), safe_reciprocal), safe_root
    ).value;

    // -> 0.5

    // We can compose a chain of safe functions (of any length) with a simple foldr/reduceRight
    // which starts by 'lifting' the numeric argument into a Maybe wrapping,
    // and then nests function applications (working from right to left)
    function safeCompose(lstFunctions, value) {
        return lstFunctions
            .reduceRight(function (a, f) {
                return bind(a, f);
            }, maybe(value));
    }

    // TEST INPUT VALUES WITH A SAFELY COMPOSED VERSION OF LOG(SQRT(1/X))

    var safe_log_root_reciprocal = function (n) {
        return safeCompose([safe_log, safe_root, safe_reciprocal], n).value;
    }

    return [-2, -1, -0.5, 0, 1 / Math.E, 1, 2, Math.E, 3, 4, 5].map(
        safe_log_root_reciprocal
    );

})();


struct maybe x::Union{Real, Missing}; end

Base.show(io::IO, m::maybe) = print(io, m.x)

unit(x) = maybe(x)
bind(f, x) = unit(f(x.x))

f1(x) = 5x
f2(x) = x + 4

a = unit(3)
b = unit(missing)

println(a, " -> ", bind(f2, bind(f1, a)))

println(b, " -> ", bind(f2, bind(f1, b)))


// version 1.2.10

import java.util.Optional

/* doubles 'i' before wrapping it */
fun getOptionalInt(i: Int) = Optional.of(2 * i)

/* returns an 'A' repeated 'i' times wrapped in an Optional<String> */
fun getOptionalString(i: Int) = Optional.of("A".repeat(i))

/* does same as above if i > 0, otherwise returns an empty Optional<String> */
fun getOptionalString2(i: Int) =
   Optional.ofNullable(if (i > 0) "A".repeat(i) else null)

fun main(args: Array<String>) {
    /* prints 10 'A's */
    println(getOptionalInt(5).flatMap(::getOptionalString).get())

    /* prints  4 'A's */
    println(getOptionalInt(2).flatMap(::getOptionalString2).get())

    /* prints 'false' as there is no value present in the Optional<String> instance */
    println(getOptionalInt(0).flatMap(::getOptionalString2).isPresent)
}


-- None is represented by an empty table.  Some is represented by any
-- array with one element.  You SHOULD NOT compare maybe values with the
-- Lua operator == because it will give incorrect results.  Use the
-- functions isMaybe(), isNone(), and isSome().

-- define once for efficiency, to avoid many different empty tables
local NONE = {}

local function unit(x) return { x } end
local Some = unit
local function isNone(mb) return #mb == 0 end
local function isSome(mb) return #mb == 1 end
local function isMaybe(mb) return isNone(mb) or isSome(mb) end

-- inverse of Some(), extract the value from the maybe; get(Some(x)) === x
local function get(mb) return mb[1] end

function maybeToStr(mb)
	return isNone(mb) and "None" or ("Some " .. tostring(get(mb)))
end

local function bind(mb, ...)  -- monadic bind for multiple functions
	local acc = mb
	for _, fun in ipairs({...}) do  -- fun should be a monadic function
		assert(type(fun) == "function")
		if isNone(acc) then return NONE
		else acc = fun(get(acc)) end
	end
	return acc
end

local function fmap(mb, ...)  -- monadic fmap for multiple functions
	local acc = mb
	for _, fun in ipairs({...}) do  -- fun should be a regular function
		assert(type(fun) == "function")
		if isNone(acc) then return NONE
		else acc = Some(fun(get(acc))) end
	end
	return acc
end
-- ^^^ End of generic maybe monad functionality ^^^

--- vvv Start of example code vvv

local function time2(x) return x * 2 end
local function plus1(x) return x + 1 end

local answer
answer = fmap(Some(3), time2, plus1, time2)
assert(get(answer)==14)

answer = fmap(NONE, time2, plus1, time2)
assert(isNone(answer))

local function safeReciprocal(x)
	if x ~= 0 then return Some(1/x) else return NONE end
end
local function safeRoot(x)
	if x >= 0 then return Some(math.sqrt(x)) else return NONE end
end
local function safeLog(x)
	if x > 0 then return Some(math.log(x)) else return NONE end
end
local function safeComputation(x)
	return bind(safeReciprocal(x), safeRoot, safeLog)
end

local function map(func, table)
	local result = {}
	for key, val in pairs(table) do
		result[key] = func(val)
	end
	return result
end

local inList = {-2, -1, -0.5, 0, math.exp (-1), 1, 2, math.exp (1), 3, 4, 5}
print("input:", table.concat(map(tostring, inList), ",  "), "\n")

local outList = map(safeComputation, inList)
print("output:", table.concat(map(maybeToStr, outList), ",  "), "\n")


// A fairly literal translation of the example program on the referenced
// WP page.  Well, it happened to be the example program the day I completed
// the task.  It seems from the WP history that there has been some churn
// in the posted example program.  The example program of the day was in
// Pascal and was credited to Niklaus Wirth, from his "Algorithms +
// Data Structures = Programs."
package main

import "fmt"

var (
    i int
    q bool
    a [9]bool
    b [17]bool
    c [15]bool // offset by 7 relative to the Pascal version
    x [9]int
)

func try(i int) {
    for j := 1; ; j++ {
        q = false
        if a[j] && b[i+j] && c[i-j+7] {
            x[i] = j
            a[j] = false
            b[i+j] = false
            c[i-j+7] = false
            if i < 8 {
                try(i + 1)
                if !q {
                    a[j] = true
                    b[i+j] = true
                    c[i-j+7] = true
                }
            } else {
                q = true
            }
        }
        if q || j == 8 {
            break
        }
    }
}

func main() {
    for i := 1; i <= 8; i++ {
        a[i] = true
    }
    for i := 2; i <= 16; i++ {
        b[i] = true
    }
    for i := 0; i <= 14; i++ {
        c[i] = true
    }
    try(1)
    if q {
        for i := 1; i <= 8; i++ {
            fmt.Println(i, x[i])
        }
    }
}


import options,math,sugar,strformat
template checkAndWrap(x:float,body:typed): untyped =
  if x.classify in {fcNormal,fcZero,fcNegZero}:
    some(body)
  else:
    none(typeof(body))
func reciprocal(x:float):Option[float] =
  let res = 1 / x
  res.checkAndWrap(res)
func log(x:float):Option[float] =
  let res = ln(x)
  res.checkAndWrap(res)
func format(x:float):Option[string] =
  x.checkAndWrap(&"{x:.2f}")

#our bind function:
func `-->`[T,U](input:Option[T], f: T->Option[U]):Option[U] =
  if input.isSome:
    f(input.get)
  else:
    none(U)

when isMainModule:
  for i in [0.9,0.0,-0.9,3.0]:
    echo some(i) --> reciprocal --> log --> format


# 20201101 added Perl programming solution

use strict;
use warnings;

use Data::Monad::Maybe;

sub safeReciprocal { ( $_[0] == 0 ) ? nothing : just(  1 /  $_[0] )   }

sub safeRoot       { ( $_[0] <  0 ) ? nothing : just( sqrt( $_[0] ) ) }

sub safeLog        { ( $_[0] <= 0 ) ? nothing : just( log ( $_[0] ) ) }

print join(' ', map {
   my $safeLogRootReciprocal = just($_)->flat_map( \&safeReciprocal )
                                       ->flat_map( \&safeRoot       )
                                       ->flat_map( \&safeLog        );
   $safeLogRootReciprocal->is_nothing ? "NaN" : $safeLogRootReciprocal->value;
} (-2, -1, -0.5, 0, exp (-1), 1, 2, exp(1), 3, 4, 5) ), "\n";


function bindf(object m, integer f)
    return f(m)
end function

function unit(object m)
    return m
end function

function times_five(object l)
    return iff(integer(l)?l*5:l)
end function

function plus_four(object l)
    return iff(integer(l)?l+4:l)
end function

procedure test(object l)
    printf(1,"%v -> %v\n", {l, bindf(bindf(l,times_five),plus_four)})
end procedure
test(3)
test("none")


def listOrder = { a, b ->
    def k = [a.size(), b.size()].min()
    def i = (0..<k).find { a[it] != b[it] }
    (i != null) ? a[i] <=> b[i] : a.size() <=> b.size()
}

def orderedPermutations = { list ->
    def n = list.size()
    (0..<n).permutations().sort(listOrder)
}

def diagonalSafe = { list ->
    def n = list.size()
    n == 1 || (0..<(n-1)).every{ i ->
        ((i+1)..<n).every{ j ->
            !([list[i]+j-i, list[i]+i-j].contains(list[j]))
        }
    }
}

def queensDistinctSolutions = { n ->
    // each permutation is an N-Rooks solution
    orderedPermutations((0..<n)).findAll (diagonalSafe)
}


"""A Maybe Monad. Requires Python >= 3.7 for type hints."""
from __future__ import annotations

from typing import Any
from typing import Callable
from typing import Generic
from typing import Optional
from typing import TypeVar
from typing import Union

T = TypeVar("T")

class Maybe(Generic[T]):
    def __init__(self, value: Union[Optional[T], Maybe[T]] = None):
        if isinstance(value, Maybe):
            self.value: Optional[T] = value.value
        else:
            self.value = value

    def __rshift__(self, func: Callable[[Optional[T]], Maybe[Any]]):
        return self.bind(func)

    def bind(self, func: Callable[[Optional[T]], Maybe[Any]]) -> Maybe[Any]:
        return func(self.value)

    def __str__(self):
        return f"{self.__class__.__name__}({self.value!r})"

def plus_one(value: Optional[int]) -> Maybe[int]:
    if value is not None:
        return Maybe[int](value + 1)
    return Maybe[int](None)

def currency(value: Optional[int]) -> Maybe[str]:
    if value is not None:
        return Maybe[str](f"${value}.00")
    return Maybe[str](None)

if __name__ == "__main__":
    test_cases = [1, 99, None, 4]

    for case in test_cases:
        m_int = Maybe[int](case)
        result = m_int >> plus_one >> currency
        # or..
        # result = m_int.bind(plus_one).bind(currency)
        print(f"{str(case):<4} -> {result}")


#lang racket

(require syntax/parse/define)

(define (bind x f) (and x (f x)))
(define return identity)

;; error when arg = 0
(define reciprocal (curry / 1))
;; error when arg < 0
(define (root x) (if (< x 0) (error 'bad) (sqrt x)))
;; error whe  arg <= 0
(define (ln x) (if (<= x 0) (error 'bad) (log x)))

(define (lift f check) (λ (x) (and (check x) (f x))))

(define safe-reciprocal (lift reciprocal (negate (curry equal? 0))))
(define safe-root (lift root (curry <= 0)))
(define safe-ln (lift ln (curry < 0)))

(define (safe-log-root-reciprocal x)
  (bind (bind (bind x safe-reciprocal) safe-root) safe-ln))

(define tests `(-2 -1 -0.5 0 1 ,(exp -1) 1 2 ,(exp 1) 3 4 5))

(map safe-log-root-reciprocal tests)

(define-syntax-parser do-macro
  [(_ [x {~datum <-} y] . the-rest) #'(bind y (λ (x) (do-macro . the-rest)))]
  [(_ e) #'e])

(define (safe-log-root-reciprocal* x)
  (do-macro [x <- (safe-reciprocal x)]
            [x <- (safe-root x)]
            [x <- (safe-ln x)]
            (return x)))

(map safe-log-root-reciprocal* tests)


my $monad = <42>;
say 'Is $monad an Int?: ', $monad ~~ Int;
say 'Is $monad a  Str?: ', $monad ~~ Str;
say 'Wait, what? What exactly is $monad?: ', $monad.^name;