$ include "seed7_05.s7i";
  include "time.s7i";

const array string: seasons is [0] ("Chaos", "Discord", "Confusion", "Bureaucracy", "The Aftermath");
const array string: weekday is [0] ("Sweetmorn", "Boomtime", "Pungenday", "Prickle-Prickle", "Setting Orange");
const array string: apostle is [0] ("Mungday", "Mojoday", "Syaday", "Zaraday",  "Maladay");
const array string: holiday is [0] ("Chaoflux", "Discoflux", "Confuflux", "Bureflux", "Afflux");

const func string: discordianDate (in time: date) is func
  result
    var string: discordianDate is "";
  local
    var integer: dyear is 0;
    var integer: doy is 0;
    var integer: dsday is 0;
  begin
    dyear := date.year + 1166;
    if isLeapYear(date.year) and date.month = 2 and date.day = 29 then
      discordianDate := "St. Tib's Day, in the YOLD " <& dyear;
    else
      doy := dayOfYear(date);
      if isLeapYear(date.year) and doy >= 60 then
        decr(doy);
      end if;
      dsday := doy rem 73; # season day
      if dsday = 5 then
        discordianDate := apostle[doy div 73] <& ", in the YOLD " <& dyear;
      elsif dsday = 50 then
        discordianDate := holiday[doy div 73] <& ", in the YOLD " <& dyear;
      else
        discordianDate := weekday[pred(doy) rem 5] <&
                          ", day " <& dsday <&
                          " of " <& seasons[doy div 73] <&
                          " in the YOLD " <& dyear;
      end if;
    end if;
  end func;

const proc: main is func
  local
    var time: today is time.value;
  begin
    today := time(NOW);
    writeln(strDate(today) <& " as Discordian date: " <& discordianDate(today));
    if  discordianDate(date(2010, 7, 22)) = "Pungenday, day 57 of Confusion in the YOLD 3176" and
        discordianDate(date(2012, 2, 28)) = "Prickle-Prickle, day 59 of Chaos in the YOLD 3178" and
        discordianDate(date(2012, 2, 29)) = "St. Tib's Day, in the YOLD 3178" and
        discordianDate(date(2012, 3,  1)) = "Setting Orange, day 60 of Chaos in the YOLD 3178" and
        discordianDate(date(2010, 1,  5)) = "Mungday, in the YOLD 3176" and
        discordianDate(date(2011, 5,  3)) = "Discoflux, in the YOLD 3177" then
      writeln("Discordian date computation works.");
    end if;
  end func;


require('Time::Piece');

var seasons = %w(Chaos Discord Confusion Bureaucracy The\ Aftermath);
var week_days = %w(Sweetmorn Boomtime Pungenday Prickle-Prickle Setting\ Orange);

func ordinal (n) {
    "#{n}" + (n % 100 ~~ [11,12,13] ? 'th'
                                    : <th st nd rd th th th th th th>[n % 10])
}

func ddate(ymd) {
    var d = %s'Time::Piece'.strptime(ymd, '%Y-%m-%d');
    var yold = "in the YOLD #{d.year + 1166}";

    var day_of_year0 = d.day_of_year;

    if (d.is_leap_year) {
        return "St. Tib's Day, #{yold}" if ([d.mon, d.mday] == [2, 29]);
        day_of_year0-- if (day_of_year0 >= 60); # Compensate for St. Tib's Day
    }

    var weekday = week_days[day_of_year0 % week_days.len];
    var season = seasons[day_of_year0 / 73];
    var season_day = ordinal(day_of_year0 % 73 + 1);

    return "#{weekday}, the #{season_day} day of #{season} #{yold}";
}

%w(2010-07-22 2012-02-28 2012-02-29 2012-03-01).each { |ymd|
    say "#{ymd} is #{ddate(ymd)}"
}


import Foundation

let monthDays = [0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334]
let seasons = ["Chaos", "Discord", "Confusion", "Bureacracy", "The Aftermath"]
let dayNames = ["Sweetmorn", "Boomtime", "Pungenday", "Prickle-Prickle", "Setting Orange"]
let holyDays1 = ["Mungday", "Mojoday", "Syaday", "Zaraday", "Maladay"]
let holyDays2 = ["Chaoflux", "Discoflux", "Confuflux", "Bureflux", "Afflux"]

func discordianDate(date: Date) -> String {
    let calendar = Calendar.current
    let year = calendar.component(.year, from: date)
    let month = calendar.component(.month, from: date)
    let day = calendar.component(.day, from: date)
    let discYear = year + 1166
    if month == 2 && day == 29 {
        return "St. Tib's Day in the YOLD \(discYear)"
    }
    let dayOfYear = monthDays[month - 1] + day - 1
    let season = dayOfYear/73
    let weekDay = dayOfYear % 5
    let dayOfSeason = 1 + dayOfYear % 73
    let ddate = "\(dayNames[weekDay]), day \(dayOfSeason) of \(seasons[season]) in the YOLD \(discYear)"
    switch (dayOfSeason) {
    case 5:
        return ddate + ". Celebrate \(holyDays1[season])!"
    case 50:
        return ddate + ". Celebrate \(holyDays2[season])!"
    default:
        return ddate
    }
}

func showDiscordianDate(year: Int, month: Int, day: Int) {
    let calendar = Calendar.current
    let date = calendar.date(from: DateComponents(year: year, month: month, day: day))!
    let ddate = discordianDate(date: date)
    let format = DateFormatter()
    format.dateFormat = "yyyy-MM-dd"
    print("\(format.string(from: date)): \(ddate)")
}

showDiscordianDate(year: 2022, month: 1, day: 20)
showDiscordianDate(year: 2020, month: 9, day: 21)
showDiscordianDate(year: 2020, month: 2, day: 29)
showDiscordianDate(year: 2019, month: 7, day: 15)
showDiscordianDate(year: 2025, month: 3, day: 19)
showDiscordianDate(year: 2017, month: 12, day: 8)


package require Tcl 8.5
proc disdate {year month day} {
    # Get the day of the year
    set now [clock scan [format %02d-%02d-%04d $day $month $year] -format %d-%m-%Y]
    scan [clock format $now -format %j] %d doy

    # Handle leap years
    if {!($year%4) && (($year%100) || !($year%400))} {
	if {$doy == 60} {
	    return "St. Tib's Day, [expr {$year + 1166}] YOLD"
	} elseif {$doy > 60} {
	    incr doy -1
	}
    }

    # Main conversion to discordian format now that special cases are handled
    incr doy -1; # Allow div/mod to work right
    set season [lindex {Chaos Discord Confusion Bureaucracy {The Aftermath}} \
	    [expr {$doy / 73}]]
    set dos [expr {$doy % 73 + 1}]
    incr year 1166
    return "$season $dos, $year YOLD"
}


import "/date" for Date
import "/fmt" for Fmt

var seasons  = ["Chaos", "Discord", "Confusion", "Bureaucracy", "The Aftermath"]
var weekdays = ["Sweetmorn", "Boomtime", "Pungenday", "Prickle-Prickle", "Setting Orange"]
var apostles = ["Mungday", "Mojoday", "Syaday", "Zaraday", "Maladay"]
var holidays = ["Chaoflux", "Discoflux", "Confuflux", "Bureflux", "Afflux"]

var discordian = Fn.new { |date|
    var y = date.year
    var yold = " in the YOLD %(y + 1166)."
    var doy = date.dayOfYear
    if (Date.isLeapYear(y)) {
        if (doy == 60) return "St. Tib's Day" + yold
        if (doy > 60) doy = doy - 1
    }
    doy = doy - 1
    var seasonDay = doy % 73 + 1
    var seasonNr = (doy/73).floor
    var weekdayNr = doy % 5
    var holyday = ""
    if (seasonDay == 5)  holyday = " Celebrate %(apostles[seasonNr])!"
    if (seasonDay == 50) holyday = " Celebrate %(holidays[seasonNr])!"
    var season = seasons[seasonNr]
    var dow = weekdays[weekdayNr]
    return Fmt.swrite("$s, day $s of $s$s$s", dow, seasonDay, season, yold, holyday)
}

var dates = [
   "2010-01-01",
   "2010-01-05",
   "2011-02-19",
   "2012-02-28",
   "2012-02-29",
   "2012-03-01",
   "2013-03-19",
   "2014-05-03",
   "2015-05-31",
   "2016-06-22",
   "2016-07-15",
   "2017-08-12",
   "2018-09-19",
   "2018-09-26",
   "2019-10-24",
   "2020-12-08",
   "2020-12-31"
]

for (date in dates) {
    var dt = Date.parse(date)
    System.print("%(date) = %(discordian.call(dt))")
}


fcn discordianDate(y,m,d){
   var [const]
   seasons=T("Chaos","Discord","Confusion","Bureaucracy","The Aftermath"),
   weekday=T("Sweetmorn","Boomtime","Pungenday","Prickle-Prickle","Setting Orange"),
   apostle=T("Mungday","Mojoday","Syaday","Zaraday","Maladay"),
   holiday=T("Chaoflux","Discoflux","Confuflux","Bureflux","Afflux"];

   dYear,isLeapYear := y + 1166, Time.Date.isLeapYear(y);
   if(isLeapYear and m==2 and d==29)
      return("St. Tib's Day, in the YOLD " + dYear);

    doy:=Time.Date.nthDayInYear(y,m,d);
    if(isLeapYear and doy>=60) doy-=1;
    dsDay:=(if(doy%73==0) 73 else doy%73); // Season day.
    if(dsDay==5)  return(String(apostle[doy/73],", in the YOLD ",dYear));
    if(dsDay==50) return(String(holiday[doy/73],", in the YOLD ",dYear));

    dSeas:=seasons[(if(doy%73==0) doy-1 else doy)/73];
    dWday:=weekday[(doy - 1)%5];
    "%s, day %s of %s in the YOLD %s".fmt(dWday,dsDay,dSeas,dYear);
}


-V
   BAKER    = 0
   COOPER   = 1
   FLETCHER = 2
   MILLER   = 3
   SMITH    = 4
   names = [‘Baker’, ‘Cooper’, ‘Fletcher’, ‘Miller’, ‘Smith’]

V floors = Array(1..5)

L
   I floors[BAKER] != 5 &
     floors[COOPER] != 1 &
     floors[FLETCHER] !C (1, 5) &
     floors[MILLER] > floors[COOPER] &
     abs(floors[SMITH] - floors[FLETCHER]) != 1 &
     abs(floors[FLETCHER] - floors[COOPER]) != 1
      L(floor) floors
         print(names[L.index]‘ lives on floor ’floor)
      L.break

   I !floors.next_permutation()
      print(‘No solution found.’)
      L.break


with Ada.Text_IO; use Ada.Text_IO;
procedure Dinesman is
   subtype Floor is Positive range 1 .. 5;
   type People is (Baker, Cooper, Fletcher, Miller, Smith);
   type Floors is array (People'Range) of Floor;
   type PtFloors is access all Floors;

   function Constrained (f : PtFloors) return Boolean is begin
      if f (Baker) /= Floor'Last and
         f (Cooper) /= Floor'First and
         Floor'First < f (Fletcher) and f (Fletcher) < Floor'Last and
         f (Miller) > f (Cooper) and
         abs (f (Smith) - f (Fletcher)) /= 1 and
         abs (f (Fletcher) - f (Cooper)) /= 1
      then return True; end if;
      return False;
   end Constrained;

   procedure Solve (list : PtFloors; n : Natural) is
      procedure Swap (I : People; J : Natural) is
         temp : constant Floor := list (People'Val (J));
      begin list (People'Val (J)) := list (I); list (I) := temp;
      end Swap;
   begin
      if n = 1 then
         if Constrained (list) then
            for p in People'Range loop
               Put_Line (p'Img & " on floor " & list (p)'Img);
            end loop;
         end if;
         return;
      end if;
      for i in People'First .. People'Val (n - 1) loop
         Solve (list, n - 1);
         if n mod 2 = 1 then Swap (People'First, n - 1);
         else Swap (i, n - 1); end if;
      end loop;
   end Solve;

   thefloors : aliased Floors;
begin
   for person in People'Range loop
      thefloors (person) := People'Pos (person) + Floor'First;
   end loop;
   Solve (thefloors'Access, Floors'Length);
end Dinesman;


# attempt to solve the dinesman Multiple Dwelling problem #

# SETUP #

# special floor values #
INT    top floor    = 4;
INT    bottom floor = 0;

# mode to specify the persons floor constraint #
MODE PERSON = STRUCT( STRING name, REF INT floor, PROC( INT )BOOL ok );

# yields TRUE if the floor of the specified person is OK, FALSE otherwise #
OP OK = ( PERSON p )BOOL: ( ok OF p )( floor OF p );

# yields TRUE if floor is adjacent to other persons floor, FALSE otherwise #
PROC adjacent = ( INT floor, other persons floor )BOOL: floor >= ( other persons floor - 1 ) AND floor <= ( other persons floor + 1 );

# displays the floor of an occupant #
PROC print floor = ( PERSON occupant )VOID: print( ( whole( floor OF occupant, -1 ), " ", name OF occupant, newline ) );

# PROBLEM STATEMENT #

# the inhabitants with their floor and constraints #
PERSON baker    = ( "Baker",    LOC INT := 0, ( INT floor )BOOL: floor /= top floor );
PERSON cooper   = ( "Cooper",   LOC INT := 0, ( INT floor )BOOL: floor /= bottom floor );
PERSON fletcher = ( "Fletcher", LOC INT := 0, ( INT floor )BOOL: floor /= top floor AND floor /= bottom floor
                                                                                AND NOT adjacent( floor, floor OF cooper ) );
PERSON miller   = ( "Miller",   LOC INT := 0, ( INT floor )BOOL: floor > floor OF cooper );
PERSON smith    = ( "Smith",    LOC INT := 0, ( INT floor )BOOL: NOT adjacent( floor, floor OF fletcher ) );

# SOLUTION #

# "brute force" solution - we run through the possible 5^5 configurations          #
# we cold optimise this by e.g. restricting f to bottom floor + 1 TO top floor - 1 #
# at the cost of reducing the flexibility of the constraints                       #
# alternatively, we could add minimum and maximum allowed floors to the PERSON     #
# STRUCT and loop through these instead of bottom floor TO top floor               #

FOR b FROM bottom floor TO top floor DO
    floor OF baker := b;
    FOR c FROM bottom floor TO top floor DO
        IF b /= c THEN
            floor OF cooper := c;
            FOR f FROM bottom floor TO top floor DO
                IF b /= f AND c /= f THEN
                    floor OF fletcher := f;
                    FOR m FROM bottom floor TO top floor DO
                        IF b /= m AND c /= m AND f /= m THEN
                            floor OF miller   := m;
                            FOR s FROM bottom floor TO top floor DO
                                IF b /= s AND c /= s AND f /= s AND m /= s THEN
                                    floor OF smith    := s;
                                    IF OK baker AND OK cooper AND OK fletcher AND OK miller AND OK smith
                                    THEN
                                        # found a solution #
                                        print floor( baker    );
                                        print floor( cooper   );
                                        print floor( fletcher );
                                        print floor( miller   );
                                        print floor( smith    )
                                    FI
                                FI
                            OD
                        FI
                    OD
                FI
            OD
        FI
    OD
OD


# syntax: GAWK -f DINESMANS_MULTIPLE-DWELLING_PROBLEM.AWK
BEGIN {
    for (Baker=1; Baker<=5; Baker++) {
      for (Cooper=1; Cooper<=5; Cooper++) {
        for (Fletcher=1; Fletcher<=5; Fletcher++) {
          for (Miller=1; Miller<=5; Miller++) {
            for (Smith=1; Smith<=5; Smith++) {
              if (rules() ~ /^1+$/) {
                printf("%d Baker\n",Baker)
                printf("%d Cooper\n",Cooper)
                printf("%d Fletcher\n",Fletcher)
                printf("%d Miller\n",Miller)
                printf("%d Smith\n",Smith)
              }
            }
          }
        }
      }
    }
    exit(0)
}
function rules(  stmt1,stmt2,stmt3,stmt4,stmt5,stmt6,stmt7) {
# The following problem statements may be changed:
#
# Baker, Cooper, Fletcher, Miller, and Smith live on different floors of an apartment house
# that contains only five floors numbered 1 (ground) to 5 (top)
    stmt1 = Baker!=Cooper && Baker!=Fletcher && Baker!=Miller && Baker!=Smith &&
            Cooper!=Fletcher && Cooper!=Miller && Cooper!=Smith &&
            Fletcher!=Miller && Fletcher!=Smith &&
            Miller!=Smith
    stmt2 = Baker != 5                     # Baker does not live on the top floor
    stmt3 = Cooper != 1                    # Cooper does not live on the bottom floor
    stmt4 = Fletcher != 5 && Fletcher != 1 # Fletcher does not live on either the top or the bottom floor
    stmt5 = Miller > Cooper                # Miller lives on a higher floor than does Cooper
    stmt6 = abs(Smith-Fletcher) != 1       # Smith does not live on a floor adjacent to Fletcher's
    stmt7 = abs(Fletcher-Cooper) != 1      # Fletcher does not live on a floor adjacent to Cooper's
    return(stmt1 stmt2 stmt3 stmt4 stmt5 stmt6 stmt7)
}
function abs(x) { if (x >= 0) { return x } else { return -x } }


print "Los apartamentos están numerados del 0 (bajo) al 4 (ático)."
print "Baker, Cooper, Fletcher, Miller y Smith viven en apartamentos diferentes."
print "- Baker no vive en el último apartamento (ático)."
print "- Cooper no vive en el piso inferior (bajo)."
print "- Fletcher no vive ni en el ático ni en el bajo."
print "- Miller vive en un apartamento más alto que Cooper."
print "- Smith no vive en un apartamento adyacente al de Fletcher."
print "- Fletcher no vive en un apartamento adyacente al de Cooper." & chr(10)

for Baker = 0 to 3
	for Cooper = 1 to 4
		for Fletcher = 1 to 3
			for Miller = 0 to 4
				for Smith = 0 to 4
					if Baker<>Cooper and Baker<>Fletcher and Baker<>Miller and Baker<>Smith and Cooper<>Fletcher and Cooper<>Miller and Cooper<>Smith and Fletcher<>Miller and Fletcher<>Smith and Miller<>Smith and Miller>Cooper and abs(Smith-Fletcher)<>1 and abs(Fletcher-Cooper)<>1 then
						print "Baker vive en el piso    "; Baker
						print "Cooper vive en el piso   "; Cooper
						print "Fletcher vive en el piso "; Fletcher
						print "Miller vive en el piso   "; Miller
						print "Smith vive en el piso    "; Smith
					end if
				next Smith
			next Miller
		next Fletcher
	next Cooper
next Baker
end


(   Baker Cooper Fletcher Miller Smith:?people
  & ( constraints
    =
      .   !arg
        : ~(? Baker)
        : ~(Cooper ?)
        : ~(Fletcher ?|? Fletcher)
        : ? Cooper ? Miller ?
        : ~(? Smith Fletcher ?|? Fletcher Smith ?)
        : ~(? Cooper Fletcher ?|? Fletcher Cooper ?)
    )
  & ( solution
    =   floors persons A Z person
      .   !arg:(?floors.?persons)
        & (   !persons:
            & constraints$!floors
            & out$("Inhabitants, from bottom to top:" !floors)
            & ~     { The ~ always fails on evaluation. Here, failure forces Bracmat to backtrack and find all solutions, not just the first one. }
          |   !persons
            :   ?A
                %?`person
                (?Z&solution$(!floors !person.!A !Z))
          )
    )
  & solution$(.!people)
|        { After outputting all solutions, the lhs of the | operator fails. The rhs of the | operator, here an empty string, is the final result. }
);


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

int verbose = 0;
#define COND(a, b) int a(int *s) { return (b); }
typedef int(*condition)(int *);

/* BEGIN problem specific setup */
#define N_FLOORS 5
#define TOP (N_FLOORS - 1)
int solution[N_FLOORS] = { 0 };
int occupied[N_FLOORS] = { 0 };

enum tenants {
	baker = 0,
	cooper,
	fletcher,
	miller,
	smith,
	phantom_of_the_opera,
};

const char *names[] = {
	"baker",
	"cooper",
	"fletcher",
	"miller",
	"smith",
};

COND(c0, s[baker] != TOP);
COND(c1, s[cooper] != 0);
COND(c2, s[fletcher] != 0 && s[fletcher] != TOP);
COND(c3, s[miller] > s[cooper]);
COND(c4, abs(s[smith] - s[fletcher]) != 1);
COND(c5, abs(s[cooper] - s[fletcher]) != 1);
#define N_CONDITIONS 6

condition cond[] = { c0, c1, c2, c3, c4, c5 };

/* END of problem specific setup */

int solve(int person)
{
	int i, j;
	if (person == phantom_of_the_opera) {
		/* check condition */
		for (i = 0; i < N_CONDITIONS; i++) {
			if (cond[i](solution)) continue;

			if (verbose) {
				for (j = 0; j < N_FLOORS; j++)
					printf("%d %s\n", solution[j], names[j]);
				printf("cond %d bad\n\n", i);
			}
			return 0;
		}

		printf("Found arrangement:\n");
		for (i = 0; i < N_FLOORS; i++)
			printf("%d %s\n", solution[i], names[i]);
		return 1;
	}

	for (i = 0; i < N_FLOORS; i++) {
		if (occupied[i]) continue;
		solution[person] = i;
		occupied[i] = 1;
		if (solve(person + 1)) return 1;
		occupied[i] = 0;
	}
	return 0;
}

int main()
{
	verbose = 0;
	if (!solve(0)) printf("Nobody lives anywhere\n");
	return 0;
}


#include <algorithm>
#include <array>
#include <cmath>
#include <functional>
#include <string>
#include <iostream>
#include <list>

int main() {
    constexpr auto floors = 5u;
    constexpr auto top = floors - 1u, bottom = 0u;

    using namespace std;
    array<string, floors> tenants = { "Baker", "Cooper", "Fletcher", "Miller", "Smith" };
    const auto floor_of = [&tenants](string t) {
        for (int i = bottom; i <= top; i++)
            if (tenants[i] == t) return i;
        throw "invalid tenant";
    };

    const list<function<bool()>> constraints = {
        [&tenants]() { return tenants[top] != "Baker"; },
        [&tenants]() { return tenants[bottom] != "Cooper"; },
        [&tenants]() { return tenants[top] != "Fletcher"; },
        [&tenants]() { return tenants[bottom] != "Fletcher"; },
        [&floor_of]() { return floor_of("Miller") > floor_of("Cooper"); },
        [&floor_of]() { return abs(floor_of("Fletcher") - floor_of("Smith")) != 1; },
        [&floor_of]() { return abs(floor_of("Fletcher") - floor_of("Cooper")) != 1; }
    };

    sort(tenants.begin(), tenants.end());
    do {
        if (all_of(constraints.begin(), constraints.end(), [](auto f) { return f(); } )) {
            for (const auto &t : tenants) cout << t << ' ';
            cout << endl;
        }
    } while (next_permutation(tenants.begin(), tenants.end()));

    return EXIT_SUCCESS;
}


public class Program
{
    public static void Main()
    {
        const int count = 5;
        const int Baker = 0, Cooper = 1, Fletcher = 2, Miller = 3, Smith = 4;
        string[] names = { nameof(Baker), nameof(Cooper), nameof(Fletcher), nameof(Miller), nameof(Smith) };

        Func<int[], bool>[] constraints = {
            floorOf => floorOf[Baker] != count-1,
            floorOf => floorOf[Cooper] != 0,
            floorOf => floorOf[Fletcher] != count-1 && floorOf[Fletcher] != 0,
            floorOf => floorOf[Miller] > floorOf[Cooper],
            floorOf => Math.Abs(floorOf[Smith] - floorOf[Fletcher]) > 1,
            floorOf => Math.Abs(floorOf[Fletcher] - floorOf[Cooper]) > 1,
        };

        var solver = new DinesmanSolver();
        foreach (var tenants in solver.Solve(count, constraints)) {
            Console.WriteLine(string.Join(" ", tenants.Select(t => names[t])));
        }
    }
}

public class DinesmanSolver
{
    public IEnumerable<int[]> Solve(int count, params Func<int[], bool>[] constraints) {
        foreach (int[] floorOf in Permutations(count)) {
            if (constraints.All(c => c(floorOf))) {
                yield return Enumerable.Range(0, count).OrderBy(i => floorOf[i]).ToArray();
            }
        }
    }

    static IEnumerable<int[]> Permutations(int length) {
        if (length == 0) {
            yield return new int[0];
            yield break;
        }
        bool forwards = false;
        foreach (var permutation in Permutations(length - 1)) {
            for (int i = 0; i < length; i++) {
                yield return permutation.InsertAt(forwards ? i : length - i - 1, length - 1).ToArray();
            }
            forwards = !forwards;
        }
    }
}

static class Extensions
{
    public static IEnumerable<T> InsertAt<T>(this IEnumerable<T> source, int position, T newElement) {
        if (source == null) throw new ArgumentNullException(nameof(source));
        if (position < 0) throw new ArgumentOutOfRangeException(nameof(position));
        return InsertAtIterator(source, position, newElement);
    }

    private static IEnumerable<T> InsertAtIterator<T>(IEnumerable<T> source, int position, T newElement) {
        int index = 0;
        foreach (T element in source) {
            if (index == position) yield return newElement;
            yield return element;
            index++;
        }
        if (index < position) throw new ArgumentOutOfRangeException(nameof(position));
        if (index == position) yield return newElement;
    }
}


shared void run() {

	function notAdjacent(Integer a, Integer b) => (a - b).magnitude >= 2;
	function allDifferent(Integer* ints) => ints.distinct.size == ints.size;

	value solutions = [
		for (baker in 1..4)
		for (cooper in 2..5)
		for (fletcher in 2..4)
		for (miller in 2..5)
		for (smith in 1..5)
		if (miller > cooper &&
			notAdjacent(smith, fletcher) &&
			notAdjacent(fletcher, cooper) &&
			allDifferent(baker, cooper, fletcher, miller, smith))
		"baker lives on ``baker``
		 cooper lives on ``cooper``
		 fletcher lives on ``fletcher``
		 miller lives on ``miller``
		 smith lives on ``smith``"
	];

	print(solutions.first else "No solution!");
}


(ns rosettacode.dinesman
  (:use [clojure.core.logic]
        [clojure.tools.macro :as macro]))

; whether x is immediately above (left of) y in list s; uses pattern matching on s
(defne aboveo [x y s]
       ([_ _ (x y . ?rest)])
       ([_ _ [_ . ?rest]] (aboveo x y ?rest)))

; whether x is on a higher floor than y
(defne highero [x y s]
       ([_ _ (x . ?rest)] (membero y ?rest))
       ([_ _ (_ . ?rest)] (highero x y ?rest)))

; whether x and y are on nonadjacent floors
(defn nonadjacento [x y s]
  (conda
    ((aboveo x y s) fail)
    ((aboveo y x s) fail)
    (succeed)))

(defn dinesmano [rs]
  (macro/symbol-macrolet [_ (lvar)]
    (all
      (permuteo ['Baker 'Cooper 'Fletcher 'Miller 'Smith] rs)
      (aboveo _ 'Baker rs) ;someone lives above Baker
      (aboveo 'Cooper _ rs) ;Cooper lives above someone
      (aboveo 'Fletcher _ rs)
      (aboveo _ 'Fletcher rs)
      (highero 'Miller 'Cooper rs)
      (nonadjacento 'Smith 'Fletcher rs)
      (nonadjacento 'Fletcher 'Cooper rs))))

(let [solns (run* [q] (dinesmano q))]
  (println "solution count:" (count solns))
  (println "solution(s) highest to lowest floor:")
  (doseq [soln solns] (println " " soln)))


(defpackage :dinesman
  (:use :cl
        :screamer)
  (:export :dinesman :dinesman-list))
(in-package :dinesman)

(defun distinctp (list)
  (equal list (remove-duplicates list)))

(defun dinesman ()
  (all-values
    (let ((baker (an-integer-between 1 5))
          (cooper (an-integer-between 1 5))
          (fletcher (an-integer-between 1 5))
          (miller (an-integer-between 1 5))
          (smith (an-integer-between 1 5)))
      (unless (distinctp (list baker cooper fletcher miller smith)) (fail))
      (when (= 5 baker) (fail))
      (when (= 1 cooper) (fail))
      (when (or (= 1 fletcher) (= 5 fletcher)) (fail))
      (unless (> miller cooper) (fail))
      (when (= 1 (abs (- fletcher smith))) (fail))
      (when (= 1 (abs (- fletcher cooper))) (fail))
      (format t "~{~A: ~A~%~}" (list 'baker baker 'cooper cooper 'fletcher fletcher 'miller  miller 'smith smith)))))

(defun dinesman-list ()
  (all-values
   (let* ((men '(baker cooper fletcher miller smith))
          (building (list (a-member-of men) (a-member-of men) (a-member-of men) (a-member-of men) (a-member-of men))))
     (unless (distinctp building) (fail))
     (when (eql (car (last building)) 'baker) (fail))
     (when (eql (first building) 'cooper) (fail))
     (when (or (eql (car (last building)) 'fletcher)
               (eql (first building) 'fletcher))
       (fail))
     (unless (> (position 'miller building)
                (position 'cooper building))
       (fail))
     (when (= 1 (abs (- (position 'fletcher building) (position 'smith building))))
       (fail))
     (when (= 1 (abs (- (position 'fletcher building) (position 'cooper building))))
       (fail))
     (format t "(~{~A~^ ~})~%" building))))


module Enumerable(T)
    def index!(element)
        index(element).not_nil!
    end
end

residents = [:Baker, :Cooper, :Fletcher, :Miller, :Smith]

predicates = [
    ->(p : Array(Symbol)){ :Baker != p.last },
    ->(p : Array(Symbol)){ :Cooper != p.first },
    ->(p : Array(Symbol)){ :Fletcher != p.first && :Fletcher != p.last },
    ->(p : Array(Symbol)){ p.index!(:Miller) > p.index!(:Cooper) },
    ->(p : Array(Symbol)){ (p.index!(:Smith) - p.index!(:Fletcher)).abs != 1 },
    ->(p : Array(Symbol)){ (p.index!(:Cooper) - p.index!(:Fletcher)).abs != 1}
]

puts residents.permutations.find { |p| predicates.all? &.call p }


import std.stdio, std.math, std.algorithm, std.traits, permutations2;

void main() {
    enum Names { Baker, Cooper, Fletcher, Miller, Smith }

    immutable(bool function(in Names[]) pure nothrow)[] predicates = [
        s => s[Names.Baker] != s.length - 1,
        s => s[Names.Cooper] != 0,
        s => s[Names.Fletcher] != 0 && s[Names.Fletcher] != s.length-1,
        s => s[Names.Miller] > s[Names.Cooper],
        s => abs(s[Names.Smith] - s[Names.Fletcher]) != 1,
        s => abs(s[Names.Cooper] - s[Names.Fletcher]) != 1];

    permutations([EnumMembers!Names])
    .filter!(solution => predicates.all!(pred => pred(solution)))
    .writeln;
}


(require 'hash)
(require' amb)

;;
;; Solver
;;

(define (dwelling-puzzle context names floors H)
;; each amb calls gives a floor to a name
    (for ((name names))
		(hash-set H name (amb context floors)))
;; They live on different floors.
    (amb-require (distinct? (amb-choices context)))
    (constraints floors H) ;; may fail and backtrack
;; result returned to amb-run
    (for/list  ((name names))
    	(cons name (hash-ref H name)))
;; (amb-fail) is possible here to see all solutions
)

(define (task names)
	(amb-run dwelling-puzzle
	(amb-make-context)
	 names
	(iota (length names)) ;; list of floors : 0,1, ....
	(make-hash)) ;; hash table : "name" -> floor
	)


defmodule Dinesman do
  def problem do
    names = ~w( Baker Cooper Fletcher Miller Smith )a
    predicates = [fn(c)-> :Baker != List.last(c) end,
                  fn(c)-> :Cooper != List.first(c) end,
                  fn(c)-> :Fletcher != List.first(c) && :Fletcher != List.last(c) end,
                  fn(c)-> floor(c, :Miller) > floor(c, :Cooper) end,
                  fn(c)-> abs(floor(c, :Smith) - floor(c, :Fletcher)) != 1 end,
                  fn(c)-> abs(floor(c, :Cooper) - floor(c, :Fletcher)) != 1 end]

    permutation(names)
    |> Enum.filter(fn candidate ->
         Enum.all?(predicates, fn predicate -> predicate.(candidate) end)
       end)
    |> Enum.each(fn name_list ->
         Enum.with_index(name_list)
         |> Enum.each(fn {name,i} -> IO.puts "#{name} lives on #{i+1}" end)
       end)
  end

  defp floor(c, name), do: Enum.find_index(c, fn x -> x == name end)

  defp permutation([]), do: [[]]
  defp permutation(list), do: (for x <- list, y <- permutation(list -- [x]), do: [x|y])
end

Dinesman.problem


-module( dinesman_multiple_dwelling ).

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

solve( All_persons, Rules ) ->
    [house(Bottom_floor, B, C, D, Top_floor) || Bottom_floor <- All_persons, B <- All_persons, C <- All_persons, D <- All_persons, Top_floor <- All_persons,
	lists:all( fun (Fun) ->	Fun( house(Bottom_floor, B, C, D, Top_floor) ) end, rules( Rules ))].

task() ->
    All_persons = [baker, cooper, fletcher, miller, smith],
    Rules = [all_on_different_floors, {not_lives_on_floor, 4, baker}, {not_lives_on_floor, 0, cooper}, {not_lives_on_floor, 4, fletcher}, {not_lives_on_floor, 0, fletcher},
          {on_higher_floor, miller, cooper}, {not_adjacent, smith, fletcher}, {not_adjacent, fletcher, cooper}],
    [House] = solve( All_persons, Rules ),
    [io:fwrite("~p lives on floor ~p~n", [lists:nth(X,	House),	X - 1]) || X <- lists:seq(1,5)].

house( A, B, C, D, E ) -> [A, B, C, D, E].

is_all_on_different_floors( [A, B, C, D, E] ) ->
        A =/= B andalso A =/= C andalso A =/= D andalso A =/= E
        andalso B =/= C andalso B =/= D andalso B =/= E
        andalso C =/= D andalso C =/= E
        andalso D =/= E.

is_not_adjacent( Person1, Person2, House ) ->
        is_not_below( Person1, Person2, House ) andalso is_not_below( Person2, Person1, House ).

is_not_below( _Person1, _Person2, [_Person] ) -> true;
is_not_below( Person1, Person2, [Person1, Person2 | _T] ) -> false;
is_not_below( Person1, Person2, [_Person | T] ) -> is_not_below( Person1, Person2, T ).

is_on_higher_floor( Person1, _Person2, [Person1 | _T] ) -> false;
is_on_higher_floor( _Person1, Person2, [Person2 | _T] ) -> true;
is_on_higher_floor( Person1, Person2, [_Person | T] ) -> is_on_higher_floor( Person1, Person2, T ).

rules( Rules ) -> lists:map( fun rules_fun/1, Rules ).

rules_fun( all_on_different_floors ) -> fun is_all_on_different_floors/1;
rules_fun( {not_lives_on_floor, N, Person} ) -> fun (House) -> Person =/= lists:nth(N + 1, House) end;
rules_fun( {on_higher_floor, Person1, Person2} ) -> fun (House) -> is_on_higher_floor( Person1, Person2, House ) end;
rules_fun( {not_below, Person1, Person2} ) -> fun (House) -> is_not_below( Person1, Person2, House ) end;
rules_fun( {not_adjacent, Person1, Person2} ) -> fun (House) ->	is_not_adjacent( Person1, Person2, House ) end.


PROGRAM DINESMAN

BEGIN
      ! Floors are numbered 0 (ground) to 4 (top)

      ! "Baker, Cooper, Fletcher, Miller, and Smith live on different floors":
      stmt1$="Baker<>Cooper AND Baker<>Fletcher AND Baker<>Miller AND "+"Baker<>Smith AND Cooper<>Fletcher AND Cooper<>Miller AND "+"Cooper<>Smith AND Fletcher<>Miller AND Fletcher<>Smith AND "+"Miller<>Smith"

      ! "Baker does not live on the top floor":
      stmt2$="Baker<>4"

      ! "Cooper does not live on the bottom floor":
      stmt3$="Cooper<>0"

      ! "Fletcher does not live on either the top or the bottom floor":
      stmt4$="Fletcher<>0 AND Fletcher<>4"

      ! "Miller lives on a higher floor than does Cooper":
      stmt5$="Miller>Cooper"

      ! "Smith does not live on a floor adjacent to Fletcher's":
      stmt6$="ABS(Smith-Fletcher)<>1"

      ! "Fletcher does not live on a floor adjacent to Cooper's":
      stmt7$="ABS(Fletcher-Cooper)<>1"

      FOR Baker=0 TO 4 DO
        FOR Cooper=0 TO 4 DO
          FOR Fletcher=0 TO 4 DO
            FOR Miller=0 TO 4 DO
              FOR Smith=0 TO 4 DO
                IF Baker<>4 AND Cooper<>0 AND Miller>Cooper THEN
                  IF Fletcher<>0 AND Fletcher<>4 AND ABS(Smith-Fletcher)<>1 AND ABS(Fletcher-Cooper)<>1 THEN
                    IF Baker<>Cooper AND Baker<>Fletcher AND Baker<>Miller AND Baker<>Smith AND Cooper<>Fletcher AND Cooper<>Miller AND Cooper<>Smith AND Fletcher<>Miller AND Fletcher<>Smith AND Miller<>Smith THEN
                      PRINT("Baker lives on floor ";Baker)
                      PRINT("Cooper lives on floor ";Cooper)
                      PRINT("Fletcher lives on floor ";Fletcher)
                      PRINT("Miller lives on floor ";Miller)
                      PRINT("Smith lives on floor ";Smith)
                    END IF
                  END IF
                END IF
              END FOR !  Smith
            END FOR !  Miller
          END FOR !  Fletcher
        END FOR !  Cooper
      END FOR !  Baker
END PROGRAM


// Dinesman's multiple-dwelling. Nigel Galloway: September 23rd., 2020
type names = |Baker=0 |Cooper=1 |Miller=2 |Smith=3 |Fletcher=4
let fN=Ring.PlainChanges [|for n in System.Enum.GetValues(typeof<names>)->n:?>names|]
let fG n g l=n|>Array.pairwise|>Array.forall(fun n->match n with (n,i) when (n=g && i=l)->false |(i,n) when (n=g && i=l)->false |_->true)
fN|>Seq.filter(fun n->n.[4]<>names.Baker && n.[0]<>names.Cooper && n.[0]<>names.Fletcher && n.[4]<>names.Fletcher && fG n names.Smith names.Fletcher
                      && fG n names.Cooper names.Fletcher && (Array.findIndex((=)names.Cooper) n) < (Array.findIndex((=)names.Miller) n))
  |>Seq.iter(Array.iteri(fun n g->printfn "%A lives on floor %d" g n))


USING: kernel
    combinators.short-circuit
    math math.combinatorics math.ranges
    sequences
    qw prettyprint ;
IN: rosetta.dinesman

: /= ( x y -- ? ) = not ;
: fifth ( seq -- elt ) 4 swap nth ;

: meets-constraints? ( seq -- ? )
    {
        [ first 5 /= ]                          ! Baker does not live on the top floor.
        [ second 1 /= ]                         ! Cooper does not live on the bottom floor.
        [ third { 1 5 } member? not ]           ! Fletcher does not live on either the top or bottom floor.
        [ [ fourth ] [ second ] bi > ]          ! Miller lives on a higher floor than does Cooper.
        [ [ fifth ] [ third ] bi - abs 1 /= ]   ! Smith does not live on a floor adjacent to Fletcher's.
        [ [ third ] [ second ] bi - abs 1 /= ]  ! Fletcher does not live on a floor adjacent to Cooper's.
    } 1&& ;

: solutions ( -- seq )
    5 [1,b] all-permutations [ meets-constraints? ] filter ;

: >names ( seq -- seq )
     [ qw{ baker cooper fletcher miller smith } nth swap 2array ] map-index ;

: dinesman ( -- )
    solutions [ >names . ] each ;


  0 enum baker                         \ enumeration of all tenants
    enum cooper
    enum fletcher
    enum miller
constant smith

create names                           \ names of all the tenants
  ," Baker"
  ," Cooper"
  ," Fletcher"
  ," Miller"
  ," Smith"                            \ get name, type it
does> swap cells + @c count type ."  lives in " ;

        5 constant #floor              \ number of floors
#floor 1- constant top                 \ top floor
        0 constant bottom              \ we're counting the floors from 0

: [email protected] [email protected] [char] 0 - ;                 ( a -- n)
: floor chars over + [email protected] ;            ( a n1 -- a n2)
                                       \ is it a valid permutation?
: perm?                                ( n -- a f)
  #floor base ! 0 swap s>d <# #floor 0 ?do # loop #>
  over >r bounds do 1 i [email protected] lshift + loop
  31 = r> swap decimal                 \ create binary mask and check
;
                                       \ test a solution
: solution?                            ( a -- a f)
  baker floor top <>                   \ baker on top floor?
  if cooper floor bottom <>            \ cooper on the bottom floor?
     if fletcher floor dup bottom <> swap top <> and
        if cooper floor swap miller floor rot >
           if smith floor swap fletcher floor rot - abs 1 <>
              if cooper floor swap fletcher floor rot - abs 1 <>
                 if true exit then     \ we found a solution!
              then
           then
        then
     then
  then false                           \ nice try, no cigar..
;
                                       ( a --)
: .solution #floor 0 do i names i chars over + [email protected] 1+ emit cr loop drop ;
                                       \ main routine
: dinesman                             ( --)
  2932 194 do
    i perm? if solution? if .solution leave else drop then else drop then
  loop
;                                      \ show the solution

dinesman


package main

import "fmt"

// The program here is restricted to finding assignments of tenants (or more
// generally variables with distinct names) to floors (or more generally
// integer values.)  It finds a solution assigning all tenants and assigning
// them to different floors.

// Change number and names of tenants here.  Adding or removing names is
// allowed but the names should be distinct; the code is not written to handle
// duplicate names.
var tenants = []string{"Baker", "Cooper", "Fletcher", "Miller", "Smith"}

// Change the range of floors here.  The bottom floor does not have to be 1.
// These should remain non-negative integers though.
const bottom = 1
const top = 5

// A type definition for readability.  Do not change.
type assignments map[string]int

// Change rules defining the problem here.  Change, add, or remove rules as
// desired.  Each rule should first be commented as human readable text, then
// coded as a function.  The function takes a tentative partial list of
// assignments of tenants to floors and is free to compute anything it wants
// with this information.  Other information available to the function are
// package level defintions, such as top and bottom.  A function returns false
// to say the assignments are invalid.
var rules = []func(assignments) bool{
    // Baker does not live on the top floor
    func(a assignments) bool {
        floor, assigned := a["Baker"]
        return !assigned || floor != top
    },
    // Cooper does not live on the bottom floor
    func(a assignments) bool {
        floor, assigned := a["Cooper"]
        return !assigned || floor != bottom
    },
    // Fletcher does not live on either the top or the bottom floor
    func(a assignments) bool {
        floor, assigned := a["Fletcher"]
        return !assigned || (floor != top && floor != bottom)
    },
    // Miller lives on a higher floor than does Cooper
    func(a assignments) bool {
        if m, assigned := a["Miller"]; assigned {
            c, assigned := a["Cooper"]
            return !assigned || m > c
        }
        return true
    },
    // Smith does not live on a floor adjacent to Fletcher's
    func(a assignments) bool {
        if s, assigned := a["Smith"]; assigned {
            if f, assigned := a["Fletcher"]; assigned {
                d := s - f
                return d*d > 1
            }
        }
        return true
    },
    // Fletcher does not live on a floor adjacent to Cooper's
    func(a assignments) bool {
        if f, assigned := a["Fletcher"]; assigned {
            if c, assigned := a["Cooper"]; assigned {
                d := f - c
                return d*d > 1
            }
        }
        return true
    },
}

// Assignment program, do not change.  The algorithm is a depth first search,
// tentatively assigning each tenant in order, and for each tenant trying each
// unassigned floor in order.  For each tentative assignment, it evaluates all
// rules in the rules list and backtracks as soon as any one of them fails.
//
// This algorithm ensures that the tenative assignments have only names in the
// tenants list, only floor numbers from bottom to top, and that tentants are
// assigned to different floors.  These rules are hard coded here and do not
// need to be coded in the the rules list above.
func main() {
    a := assignments{}
    var occ [top + 1]bool
    var df func([]string) bool
    df = func(u []string) bool {
        if len(u) == 0 {
            return true
        }
        tn := u[0]
        u = u[1:]
    f:
        for f := bottom; f <= top; f++ {
            if !occ[f] {
                a[tn] = f
                for _, r := range rules {
                    if !r(a) {
                        delete(a, tn)
                        continue f
                    }
                }
                occ[f] = true
                if df(u) {
                    return true
                }
                occ[f] = false
                delete(a, tn)
            }
        }
        return false
    }
    if !df(tenants) {
        fmt.Println("no solution")
        return
    }
    for t, f := range a {
        fmt.Println(t, f)
    }
}


import Data.List (permutations)
import Control.Monad (guard)

dinesman :: [(Int,Int,Int,Int,Int)]
dinesman = do
  -- baker, cooper, fletcher, miller, smith are integers representing
  -- the floor that each person lives on, from 1 to 5

  -- Baker, Cooper, Fletcher, Miller, and Smith live on different floors
  -- of an apartment house that contains only five floors.
  [baker, cooper, fletcher, miller, smith] <- permutations [1..5]

  -- Baker does not live on the top floor.
  guard $ baker /= 5

  -- Cooper does not live on the bottom floor.
  guard $ cooper /= 1

  -- Fletcher does not live on either the top or the bottom floor.
  guard $ fletcher /= 5 && fletcher /= 1

  -- Miller lives on a higher floor than does Cooper.
  guard $ miller > cooper

  -- Smith does not live on a floor adjacent to Fletcher's.
  guard $ abs (smith - fletcher) /= 1

  -- Fletcher does not live on a floor adjacent to Cooper's.
  guard $ abs (fletcher - cooper) /= 1

  -- Where does everyone live?
  return (baker, cooper, fletcher, miller, smith)

main :: IO ()
main = do
  print $ head dinesman -- print first solution: (3,2,4,5,1)
  print dinesman -- print all solutions (only one): [(3,2,4,5,1)]


invocable all
global nameL, nameT, rules

procedure main() # Dinesman

nameT := table()
nameL := ["Baker", "Cooper", "Fletcher", "Miller", "Smith"]
rules := [ [ distinct ],
           [ "~=",        "Baker",    top()      ],
           [ "~=",        "Cooper",   bottom()   ],
           [ "~=",        "Fletcher", top()      ],
           [ "~=",        "Fletcher", bottom()   ],
           [ ">",         "Miller",   "Cooper"   ],
           [ notadjacent, "Smith",    "Fletcher" ],
           [ notadjacent, "Fletcher", "Cooper"   ],
           [ showsolution ],
           [ stop ] ]

if not solve(1) then
   write("No solution found.")
end

procedure dontstop()           # use if you want to search for all solutions
end

procedure showsolution()       # show the soluton
   write("The solution is:")
   every write("   ",n := !nameL, " lives in ", nameT[n])
   return
end

procedure eval(n)              # evaluate a rule
   r := copy(rules[n-top()])
   every r[i := 2 to *r] := rv(r[i])
   if get(r)!r then suspend
end

procedure rv(x)                # return referenced value if it exists
return \nameT[x] | x
end

procedure solve(n)             # recursive solver
   if n > top() then {         # apply rules
      if n <= top() + *rules then
         ( eval(n) & solve(n+1) ) | fail
      }
   else                        # setup locations
      (( nameT[nameL[n]] := bottom() to top() ) & solve(n + 1)) | fail
   return
end

procedure distinct(a,b)        # ensure each name is distinct
   if nameT[n := !nameL] = nameT[n ~== key(nameT)] then fail
   suspend
end

procedure notadjacent(n1,n2)   # ensure n1,2 are not adjacent
   if not adjacent(n1,n2) then suspend
end

procedure adjacent(n1,n2)      # ensure n1,2 are adjacent
   if abs(n1 - n2) = 1 then suspend
end

procedure bottom()             # return bottom
   return if *nameL > 0 then 1 else 0
end

procedure top()                # return top
   return *nameL
end


import java.util.*;

class DinesmanMultipleDwelling {

    private static void generatePermutations(String[] apartmentDwellers, Set<String> set, String curPermutation) {
        for (String s : apartmentDwellers) {
            if (!curPermutation.contains(s)) {
                String nextPermutation = curPermutation + s;
                if (nextPermutation.length() == apartmentDwellers.length) {
                    set.add(nextPermutation);
                } else {
                    generatePermutations(apartmentDwellers, set, nextPermutation);
                }
            }
        }
    }

    private static boolean topFloor(String permutation, String person) { //Checks to see if the person is on the top floor
        return permutation.endsWith(person);
    }

    private static boolean bottomFloor(String permutation, String person) {//Checks to see if the person is on the bottom floor
        return permutation.startsWith(person);
    }

    public static boolean livesAbove(String permutation, String upperPerson, String lowerPerson) {//Checks to see if the person lives above the other person
        return permutation.indexOf(upperPerson) > permutation.indexOf(lowerPerson);
    }

    public static boolean adjacent(String permutation, String person1, String person2) { //checks to see if person1 is adjacent to person2
        return (Math.abs(permutation.indexOf(person1) - permutation.indexOf(person2)) == 1);
    }

    private static boolean isPossible(String s) {
        /*
         What this does should be obvious...proper explaination can be given if needed
         Conditions here Switching any of these to ! or reverse will change what is given as a result

         example
         if(topFloor(s, "B"){
         }
         to
         if(!topFloor(s, "B"){
         }
         or the opposite
         if(!topFloor(s, "B"){
         }
         to
         if(topFloor(s, "B"){
         }
         */
        if (topFloor(s, "B")) {//B is on Top Floor
            return false;
        }
        if (bottomFloor(s, "C")) {//C is on Bottom Floor
            return false;
        }
        if (topFloor(s, "F") || bottomFloor(s, "F")) {// F is on top or bottom floor
            return false;
        }
        if (!livesAbove(s, "M", "C")) {// M does not live above C
            return false;
        }
        if (adjacent(s, "S", "F")) { //S lives adjacent to F
            return false;
        }
        return !adjacent(s, "F", "C"); //F does not live adjacent to C
    }

    public static void main(String[] args) {
        Set<String> set = new HashSet<String>();
        generatePermutations(new String[]{"B", "C", "F", "M", "S"}, set, ""); //Generates Permutations
        for (Iterator<String> iterator = set.iterator(); iterator.hasNext();) {//Loops through iterator
            String permutation = iterator.next();
            if (!isPossible(permutation)) {//checks to see if permutation is false if so it removes it
                iterator.remove();
            }
        }
        for (String s : set) {
            System.out.println("Possible arrangement: " + s);
            /*
            Prints out possible arranagement...changes depending on what you change in the "isPossible method"
             */
        }
    }
}


(() => {
    'use strict';

    // concatMap :: (a -> [b]) -> [a] -> [b]
    const concatMap = (f, xs) => [].concat.apply([], xs.map(f));

    // range :: Int -> Int -> [Int]
    const range = (m, n) =>
        Array.from({
            length: Math.floor(n - m) + 1
        }, (_, i) => m + i);

    // and :: [Bool] -> Bool
    const and = xs => {
        let i = xs.length;
        while (i--)
            if (!xs[i]) return false;
        return true;
    }

    // nubBy :: (a -> a -> Bool) -> [a] -> [a]
    const nubBy = (p, xs) => {
        const x = xs.length ? xs[0] : undefined;
        return x !== undefined ? [x].concat(
            nubBy(p, xs.slice(1)
                .filter(y => !p(x, y)))
        ) : [];
    }

    // PROBLEM DECLARATION

    const floors = range(1, 5);

    return  concatMap(b =>
            concatMap(c =>
            concatMap(f =>
            concatMap(m =>
            concatMap(s =>
                and([ // CONDITIONS
                    nubBy((a, b) => a === b, [b, c, f, m, s]) // all floors singly occupied
                    .length === 5,
                    b !== 5, c !== 1, f !== 1, f !== 5,
                    m > c, Math.abs(s - f) > 1, Math.abs(c - f) > 1
                ]) ? [{
                    Baker: b,
                    Cooper: c,
                    Fletcher: f,
                    Miller: m,
                    Smith: s
                }] : [],
                floors), floors), floors), floors), floors);

    // --> [{"Baker":3, "Cooper":2, "Fletcher":4, "Miller":5, "Smith":1}]
})();


# Input: an array representing the apartment house, with null at a
#    particular position signifying that the identity of the occupant
#    there has not yet been determined.
# Output: an elaboration of the input array but including person, and
#   satisfying cond, where . in cond refers to the placement of person
def resides(person; cond):
  range(0;5) as $n
  | if (.[$n] == null or .[$n] == person) and ($n|cond) then .[$n] = person
    else empty   # no elaboration is possible
    end ;

# English:
def top: 4;
def bottom: 0;
def higher(j): . > j;
def adjacent(j): (. - j) | (. == 1 or . == -1);


using Combinatorics

function solve(n::Vector{<:AbstractString}, pred::Vector{<:Function})
    rst = Vector{typeof(n)}(0)
    for candidate in permutations(n)
        if all(p(candidate) for p in predicates)
            push!(rst, candidate)
        end
    end
    return rst
end

Names = ["Baker", "Cooper", "Fletcher", "Miller", "Smith"]
predicates = [
    (s) -> last(s) != "Baker",
    (s) -> first(s) != "Cooper",
    (s) -> first(s) != "Fletcher" && last(s) != "Fletcher",
    (s) -> findfirst(s, "Miller") > findfirst(s, "Cooper"),
    (s) -> abs(findfirst(s, "Smith") - findfirst(s, "Fletcher")) != 1,
    (s) -> abs(findfirst(s, "Cooper") - findfirst(s, "Fletcher")) != 1]

solutions = solve(Names, predicates)
foreach(x -> println(join(x, ", ")), solutions)


perm: {[email protected]@&n=(#?:)'m:!n#n:#x}
filter: {y[& x'y]}
reject: {y[& ~x'y]}
adjacent: {1 = _abs (z?x) - (z?y)}

p: perm[`Baker `Cooper `Fletcher `Miller `Smith]
p: reject[{`Cooper=x[0]}; p]
p: reject[{`Baker=x[4]}; p]
p: filter[{(x ? `Miller) > (x ? `Cooper)}; p]
p: reject[{adjacent[`Smith; `Fletcher; x]}; p]
p: reject[{adjacent[`Cooper; `Fletcher; x]}; p]
p: reject[{(x ? `Fletcher)_in (0 4)}; p]


// version 1.1.3

typealias Predicate = (List<String>) -> Boolean

fun <T> permute(input: List<T>): List<List<T>> {
    if (input.size == 1) return listOf(input)
    val perms = mutableListOf<List<T>>()
    val toInsert = input[0]
    for (perm in permute(input.drop(1))) {
        for (i in 0..perm.size) {
            val newPerm = perm.toMutableList()
            newPerm.add(i, toInsert)
            perms.add(newPerm)
        }
    }
    return perms
}

/* looks for for all possible solutions, not just the first */
fun dinesman(occupants: List<String>, predicates: List<Predicate>) =
    permute(occupants).filter { perm -> predicates.all { pred -> pred(perm) } }

fun main(args: Array<String>) {
    val occupants = listOf("Baker", "Cooper", "Fletcher", "Miller", "Smith")

    val predicates = listOf<Predicate>(
        { it.last() != "Baker" },
        { it.first() != "Cooper" },
        { it.last() != "Fletcher" && it.first() != "Fletcher" },
        { it.indexOf("Miller") > it.indexOf("Cooper") },
        { Math.abs(it.indexOf("Smith") - it.indexOf("Fletcher")) > 1 },
        { Math.abs(it.indexOf("Fletcher") - it.indexOf("Cooper")) > 1 }
    )

    val solutions = dinesman(occupants, predicates)
    val size = solutions.size
    if (size == 0) {
        println("No solutions found")
    }
    else {
        val plural = if (size == 1) "" else "s"
        println("$size solution$plural found, namely:\n")
        for (solution in solutions) {
            for ((i, name) in solution.withIndex()) {
                println("Floor ${i + 1} -> $name")
            }
            println()
        }
    }
}


local wrap, yield = coroutine.wrap, coroutine.yield
local function perm(n)
    local r = {}
    for i=1,n do r[i]=i end
  return wrap(function()
    local function swap(m)
      if m==0 then
        yield(r)
      else
        for i=m,1,-1 do
          r[i],r[m]=r[m],r[i]
          swap(m-1)
          r[i],r[m]=r[m],r[i]
        end
      end
    end
    swap(n)
  end)
end

local function iden(...)return ... end
local function imap(t,f)
  local r,fn = {m=imap, c=table.concat, u=table.unpack}, f or iden
  for i=1,#t do r[i]=fn(t[i])end
  return r
end

local tenants = {'Baker', 'Cooper', 'Fletcher', 'Miller', 'Smith'}

local conds = {
  'Baker  ~= TOP',
  'Cooper ~= BOTTOM',
  'Fletcher ~= TOP and Fletcher~= BOTTOM',
  'Miller > Cooper',
  'Smith + 1 ~= Fletcher and Smith - 1 ~= Fletcher',
  'Cooper + 1 ~= Fletcher and Cooper - 1 ~= Fletcher',
}

local function makePredicate(conds, tenants)
  return load('return function('..imap(tenants):c','..
    ') return ' ..
    imap(conds,function(c)
      return string.format("(%s)",c)
    end):c"and "..
    " end ",'-',nil,{TOP=5, BOTTOM=1})()
end

local function solve (conds, tenants)
  local try, pred, upk = perm(#tenants), makePredicate(conds, tenants), table.unpack
  local answer = try()
  while answer and not pred(upk(answer)) do answer = try()end
  if answer then
    local floor = 0
    return imap(answer, function(person)
        floor=floor+1;
        return string.format(" %s lives on floor %d",tenants[floor],person)
    end):c"\n"
  else
    return nil, 'no solution'
  end
end

print(solve (conds, tenants))


{Baker, Cooper, Fletcher, Miller, Smith};
(Unequal @@ %) && (And @@ (0 < # < 6 & /@ %)) &&
  Baker < 5 &&
  Cooper > 1 &&
  1 < Fletcher < 5 &&
  Miller > Cooper &&
  Abs[Smith - Fletcher] > 1 &&
  Abs[Cooper - Fletcher] > 1 //
 Reduce[#, %, Integers] &


%Dinesman's multiple-dwelling problem. Nigel Galloway, September 25th., 2020
include "alldifferent.mzn";
enum names={Baker,Cooper,Miller,Smith,Fletcher};
array[names] of var 1..5: res; constraint alldifferent([res[n] | n in names]);
constraint res[Baker]    !=5;
constraint res[Cooper]   !=1;
constraint res[Fletcher] !=1;
constraint res[Fletcher] !=5;
constraint abs(res[Smith] -res[Fletcher]) > 1;
constraint abs(res[Cooper]-res[Fletcher]) > 1;
constraint res[Cooper] < res[Miller];
output["\(n) resides on floor \(res[n])\n" | n in names]


import algorithm

type

  Person {.pure.} = enum Baker, Cooper, Fletcher, Miller, Smith
  Floor = range[1..5]

var floors: array[Person, Floor] = [Floor 1, 2, 3, 4, 5]

while true:
  if floors[Baker] != 5 and
     floors[Cooper] != 1 and
     floors[Fletcher] notin [1, 5] and
     floors[Miller] > floors[Cooper] and
     abs(floors[Smith] - floors[Fletcher]) != 1 and
     abs(floors[Fletcher] - floors[Cooper]) != 1:
       for person, floor in floors:
         echo person, " lives on floor ", floor
       break
  if not floors.nextPermutation():
    echo "No solution found."
    break


use strict;
use warnings;
use feature <state say>;
use List::Util 1.33 qw(pairmap);
use Algorithm::Permute qw(permute);

our %predicates = (
#                       | object    | sprintf format for Perl expression |
#   --------------------+-----------+------------------------------------+
    'on bottom'      => [ ''        , '$f[%s] == 1'                      ],
    'on top'         => [ ''        , '$f[%s] == @f'                     ],
    'lower than'     => [ 'person'  , '$f[%s] < $f[%s]'                  ],
    'higher than'    => [ 'person'  , '$f[%s] > $f[%s]'                  ],
    'directly below' => [ 'person'  , '$f[%s] == $f[%s] - 1'             ],
    'directly above' => [ 'person'  , '$f[%s] == $f[%s] + 1'             ],
    'adjacent to'    => [ 'person'  , 'abs($f[%s] - $f[%s]) == 1'        ],
    'on'             => [ 'ordinal' , '$f[%s] == \'%s\''                 ],
);

our %nouns = (
    'person'  => qr/[a-z]+/i,
    'ordinal' => qr/1st | 2nd | 3rd | \d+th/x,
);

sub parse_and_solve {
    my @facts = @_;

    state $parser = qr/^(?<subj>$nouns{person}) (?<not>not )?(?|@{[
                            join '|', pairmap {
                                "(?<pred>$a)" .
                                ($b->[0] ? " (?<obj>$nouns{$b->[0]})" : '')
                            } %predicates
                        ]})$/;

    my (@expressions, %ids, $i);
    my $id = sub { defined $_[0] ? $ids{$_[0]} //= $i++ : () };

    foreach (@facts) {
        /$parser/ or die "Cannot parse '$_'\n";

        my $pred = $predicates{$+{pred}};
        { no warnings;
          my $expr = '(' . sprintf($pred->[1], $id->($+{subj}),
                           $pred->[0] eq 'person' ? $id->($+{obj}) : $+{obj}). ')';
          $expr = '!' . $expr if $+{not};
          push @expressions, $expr;
        }
    }

    my @f = 1..$i;
    eval '
          permute {
              say join(", ", pairmap { "$f[$b] $a" } %ids)
                  if ('.join(' && ', @expressions).');
          } @f;';
}


with javascript_semantics
enum Baker, Cooper, Fletcher, Miller, Smith
constant names={"Baker","Cooper","Fletcher","Miller","Smith"}

procedure test(sequence flats)
    if flats[Baker]!=5
    and flats[Cooper]!=1
    and not find(flats[Fletcher],{1,5})
    and flats[Miller]>flats[Cooper]
    and abs(flats[Smith]-flats[Fletcher])!=1
    and abs(flats[Fletcher]-flats[Cooper])!=1 then
        for i=1 to 5 do
            ?{names[i],flats[i]}
        end for
    end if
end procedure

for i=1 to factorial(5) do
    test(permute(i,tagset(5)))
end for


import util.
import cp.

dinesman_cp =>
   println(dinesman_cp),
   N = 5,
   X = [Baker, Cooper, Fletcher, Miller, Smith],
   X :: 1..N,

   all_different(X),

   % Baker does not live on the fifth floor.
   Baker #!= 5,

   % Cooper does not live on the first floor.
   Cooper #!= 1,

   % Fletcher does not live on either the fifth or the first floor.
   Fletcher #!= 5,
   Fletcher #!= 1,

   % Miller lives on a higher floor than does Cooper.
   Miller #> Cooper,

   % Smith does not live on a floor adjacent to Fletcher'.
   abs(Smith-Fletcher) #> 1,

   % Fletcher does not live on a floor adjacent to Cooper's.
   abs(Fletcher-Cooper) #> 1,

   solve(X),

   println([baker=Baker, cooper=Cooper, fletcher=Fletcher, miller=Miller, smith=Smith]).


# Problem statement
(be dwelling (@Tenants)
   (permute (Baker Cooper Fletcher Miller Smith) @Tenants)
   (not (topFloor Baker @Tenants))
   (not (bottomFloor Cooper @Tenants))
   (not (or ((topFloor Fletcher @Tenants)) ((bottomFloor Fletcher @Tenants))))
   (higherFloor Miller Cooper @Tenants)
   (not (adjacentFloor Smith Fletcher @Tenants))
   (not (adjacentFloor Fletcher Cooper @Tenants)) )

# Utility rules
(be topFloor (@Tenant @Lst)
   (equal (@ @ @ @ @Tenant) @Lst) )

(be bottomFloor (@Tenant @Lst)
   (equal (@Tenant @ @ @ @) @Lst) )

(be higherFloor (@Tenant1 @Tenant2 @Lst)
   (append @ @Rest @Lst)
   (equal (@Tenant2 . @Higher) @Rest)
   (member @Tenant1 @Higher) )

(be adjacentFloor (@Tenant1 @Tenant2 @Lst)
   (append @ @Rest @Lst)
   (or
      ((equal (@Tenant1 @Tenant2 . @) @Rest))
      ((equal (@Tenant2 @Tenant1 . @) @Rest)) ) )


# Floors are numbered 1 (ground) to 5 (top)

# Baker, Cooper, Fletcher, Miller, and Smith live on different floors:
$statement1 = '$baker  -ne $cooper -and $baker    -ne $fletcher -and $baker    -ne $miller -and
               $baker  -ne $smith  -and $cooper   -ne $fletcher -and $cooper   -ne $miller -and
               $cooper -ne $smith  -and $fletcher -ne $miller   -and $fletcher -ne $smith  -and
               $miller -ne $smith'

# Baker does not live on the top floor:
$statement2 = '$baker -ne 5'

# Cooper does not live on the bottom floor:
$statement3 = '$cooper -ne 1'

# Fletcher does not live on either the top or the bottom floor:
$statement4 = '$fletcher -ne 1 -and $fletcher -ne 5'

# Miller lives on a higher floor than does Cooper:
$statement5 = '$miller -gt $cooper'

# Smith does not live on a floor adjacent to Fletcher's:
$statement6 = '[Math]::Abs($smith - $fletcher) -ne 1'

# Fletcher does not live on a floor adjacent to Cooper's:
$statement7 = '[Math]::Abs($fletcher - $cooper) -ne 1'

for ($baker = 1; $baker -lt 6; $baker++)
{
    for ($cooper = 1; $cooper -lt 6; $cooper++)
    {
        for ($fletcher = 1; $fletcher -lt 6; $fletcher++)
        {
            for ($miller = 1; $miller -lt 6; $miller++)
            {
                for ($smith = 1; $smith -lt 6; $smith++)
                {
                    if (Invoke-Expression $statement2)
                    {
                        if (Invoke-Expression $statement3)
                        {
                            if (Invoke-Expression $statement5)
                            {
                                if (Invoke-Expression $statement4)
                                {
                                    if (Invoke-Expression $statement6)
                                    {
                                        if (Invoke-Expression $statement7)
                                        {
                                            if (Invoke-Expression $statement1)
                                            {
                                                $multipleDwellings = @()
                                                $multipleDwellings+= [PSCustomObject]@{Name = "Baker"   ; Floor = $baker}
                                                $multipleDwellings+= [PSCustomObject]@{Name = "Cooper"  ; Floor = $cooper}
                                                $multipleDwellings+= [PSCustomObject]@{Name = "Fletcher"; Floor = $fletcher}
                                                $multipleDwellings+= [PSCustomObject]@{Name = "Miller"  ; Floor = $miller}
                                                $multipleDwellings+= [PSCustomObject]@{Name = "Smith"   ; Floor = $smith}
                                            }
                                        }
                                    }
                                }
                            }
                        }
                    }
                }
            }
        }
    }
}


:- use_module(library(clpfd)).

:- dynamic top/1, bottom/1.

% Baker does not live on the top floor
rule1(L) :-
	member((baker, F), L),
	top(Top),
	F #\= Top.

% Cooper does not live on the bottom floor.
rule2(L) :-
	member((cooper, F), L),
	bottom(Bottom),
	F #\= Bottom.

% Fletcher does not live on either the top or the bottom floor.
rule3(L) :-
	member((fletcher, F), L),
	top(Top),
	bottom(Bottom),
	F #\= Top,
	F #\= Bottom.

% Miller lives on a higher floor than does Cooper.
rule4(L) :-
	member((miller, Fm), L),
	member((cooper, Fc), L),
	Fm #> Fc.

% Smith does not live on a floor adjacent to Fletcher's.
rule5(L) :-
	member((smith, Fs), L),
	member((fletcher, Ff), L),
	abs(Fs-Ff) #> 1.

% Fletcher does not live on a floor adjacent to Cooper's.
rule6(L) :-
	member((cooper, Fc), L),
	member((fletcher, Ff), L),
	abs(Fc-Ff) #> 1.

init(L) :-
	% we need to define top and bottom
	assert(bottom(1)),
	length(L, Top),
	assert(top(Top)),

	% we say that they are all in differents floors
	bagof(F, X^member((X, F), L), LF),
	LF ins 1..Top,
	all_different(LF),

	% Baker does not live on the top floor
	rule1(L),

	% Cooper does not live on the bottom floor.
	rule2(L),

	% Fletcher does not live on either the top or the bottom floor.
	rule3(L),

	% Miller lives on a higher floor than does Cooper.
	rule4(L),

	% Smith does not live on a floor adjacent to Fletcher's.
	rule5(L),

	% Fletcher does not live on a floor adjacent to Cooper's.
	rule6(L).

solve(L) :-
	bagof(F, X^member((X, F), L), LF),
	label(LF).

dinners :-
	retractall(top(_)), retractall(bottom(_)),
	L = [(baker, _Fb), (cooper, _Fc), (fletcher, _Ff), (miller, _Fm), (smith, _Fs)],
	init(L),
	solve(L),
	maplist(writeln, L).


import re
from itertools import product

problem_re = re.compile(r"""(?msx)(?:

# Multiple names of form n1, n2, n3, ... , and nK
(?P<namelist> [a-zA-Z]+ (?: , \s+ [a-zA-Z]+)* (?: ,? \s+ and) \s+ [a-zA-Z]+ )

# Flexible floor count (2 to 10 floors)
| (?:  .* house \s+ that \s+ contains \s+ only \s+
  (?P<floorcount> two|three|four|five|six|seven|eight|nine|ten ) \s+ floors \s* \.)

# Constraint: "does not live on the n'th floor"
|(?: (?P<not_live>  \b [a-zA-Z]+ \s+ does \s+ not \s+ live \s+ on \s+ the \s+
  (?: top|bottom|first|second|third|fourth|fifth|sixth|seventh|eighth|ninth|tenth) \s+ floor \s* \. ))

# Constraint: "does not live on either the I'th or the J'th [ or the K'th ...] floor
|(?P<not_either> \b [a-zA-Z]+ \s+ does \s+ not \s+ live \s+ on \s+ either
  (?: \s+ (?: or \s+)? the \s+
    (?: top|bottom|first|second|third|fourth|fifth|sixth|seventh|eighth|ninth|tenth))+ \s+ floor \s* \. )

# Constraint: "P1 lives on a higher/lower floor than P2 does"
|(?P<hi_lower> \b  [a-zA-Z]+ \s+ lives \s+ on \s+ a \s (?: higher|lower)
   \s+ floor \s+ than (?: \s+ does)  \s+  [a-zA-Z]+ \s* \. )

# Constraint: "P1 does/does not live on a floor adjacent to P2's"
|(?P<adjacency>  \b [a-zA-Z]+ \s+ does (?:\s+ not)? \s+ live \s+ on \s+ a \s+
   floor \s+ adjacent \s+ to \s+  [a-zA-Z]+ (?: 's )? \s* \. )

# Ask for the solution
|(?P<question> Where \s+ does \s+ everyone \s+ live \s* \?)

)
""")

names, lennames = None, None
floors = None
constraint_expr = 'len(set(alloc)) == lennames' # Start with all people on different floors

def do_namelist(txt):
    " E.g. 'Baker, Cooper, Fletcher, Miller, and Smith'"
    global names, lennames
    names = txt.replace(' and ', ' ').split(', ')
    lennames = len(names)

def do_floorcount(txt):
    " E.g. 'five'"
    global floors
    floors = '||two|three|four|five|six|seven|eight|nine|ten'.split('|').index(txt)

def do_not_live(txt):
    " E.g. 'Baker does not live on the top floor.'"
    global constraint_expr
    t = txt.strip().split()
    who, floor = t[0], t[-2]
    w, f = (names.index(who),
            ('|first|second|third|fourth|fifth|sixth|' +
             'seventh|eighth|ninth|tenth|top|bottom|').split('|').index(floor)
            )
    if f == 11: f = floors
    if f == 12: f = 1
    constraint_expr += ' and alloc[%i] != %i' % (w, f)

def do_not_either(txt):
    " E.g. 'Fletcher does not live on either the top or the bottom floor.'"
    global constraint_expr
    t = txt.replace(' or ', ' ').replace(' the ', ' ').strip().split()
    who, floor = t[0], t[6:-1]
    w, fl = (names.index(who),
             [('|first|second|third|fourth|fifth|sixth|' +
               'seventh|eighth|ninth|tenth|top|bottom|').split('|').index(f)
              for f in floor]
             )
    for f in fl:
        if f == 11: f = floors
        if f == 12: f = 1
        constraint_expr += ' and alloc[%i] != %i' % (w, f)

def do_hi_lower(txt):
    " E.g. 'Miller lives on a higher floor than does Cooper.'"
    global constraint_expr
    t = txt.replace('.', '').strip().split()
    name_indices = [names.index(who) for who in (t[0], t[-1])]
    if 'lower' in t:
        name_indices = name_indices[::-1]
    constraint_expr += ' and alloc[%i] > alloc[%i]' % tuple(name_indices)

def do_adjacency(txt):
    ''' E.g. "Smith does not live on a floor adjacent to Fletcher's."'''
    global constraint_expr
    t = txt.replace('.', '').replace("'s", '').strip().split()
    name_indices = [names.index(who) for who in (t[0], t[-1])]
    constraint_expr += ' and abs(alloc[%i] - alloc[%i]) > 1' % tuple(name_indices)

def do_question(txt):
    global constraint_expr, names, lennames

    exec_txt = '''
for alloc in product(range(1,floors+1), repeat=len(names)):
    if %s:
        break
else:
    alloc = None
''' % constraint_expr
    exec(exec_txt, globals(), locals())
    a = locals()['alloc']
    if a:
        output= ['Floors are numbered from 1 to %i inclusive.' % floors]
        for a2n in zip(a, names):
            output += ['  Floor %i is occupied by %s' % a2n]
        output.sort(reverse=True)
        print('\n'.join(output))
    else:
        print('No solution found.')
    print()

handler = {
    'namelist': do_namelist,
    'floorcount': do_floorcount,
    'not_live': do_not_live,
    'not_either': do_not_either,
    'hi_lower': do_hi_lower,
    'adjacency': do_adjacency,
    'question': do_question,
    }
def parse_and_solve(problem):
    p = re.sub(r'\s+', ' ', problem).strip()
    for x in problem_re.finditer(p):
        groupname, txt = [(k,v) for k,v in x.groupdict().items() if v][0]
        #print ("%r, %r" % (groupname, txt))
        handler[groupname](txt)


names = unlist(strsplit("baker cooper fletcher miller smith", " "))

test <- function(floors) {
  f <- function(name) which(name == floors)
  if ((f('baker') != 5) &&
      (f('cooper') != 1) &&
      (any(f('fletcher') == 2:4)) &&
      (f('miller') > f('cooper')) &&
      (abs(f('fletcher') - f('cooper')) > 1) &&
      (abs(f('smith') - f('fletcher')) > 1))
    cat("\nFrom bottom to top: --> ", floors, "\n")
}

do.perms <- function(seq, func, built = c()){
  if (0 == length(seq))  func(built)
  else  for (x in seq) do.perms( seq[!seq==x], func, c(x, built)) }


#lang racket

;; A quick `amb' implementation
(define fails '())
(define (fail) (if (pair? fails) ((car fails)) (error "no more choices!")))
(define (amb xs)
  (let/cc k (set! fails (cons k fails)))
  (if (pair? xs) (begin0 (car xs) (set! xs (cdr xs)))
      (begin (set! fails (cdr fails)) (fail))))
(define (assert . conditions) (when (memq #f conditions) (fail)))

;; Convenient macro for definining problem items
(define-syntax-rule (with: all (name ...) #:in choices body ...)
  (let* ([cs choices] [name (amb cs)] ... [all `([,name name] ...)]) body ...))

;; ===== problem translation starts here =====

;; Baker, Cooper, Fletcher, Miller, and Smith live on different floors
;; of an apartment house that contains only five floors.
(with: residents [Baker Cooper Fletcher Miller Smith] #:in (range 1 6)
  ;; Some helpers
  (define (on-top    x) (for/and ([y residents]) (x . >= . (car y))))
  (define (on-bottom x) (for/and ([y residents]) (x . <= . (car y))))
  (define (adjacent x y) (= 1 (abs (- x y))))
  (assert
   ;; ... live on different floors ...
   (assert (= 5 (length (remove-duplicates (map car residents)))))
   ;; Baker does not live on the top floor.
   (not (on-top Baker))
   ;; Cooper does not live on the bottom floor.
   (not (on-bottom Cooper))
   ;; Fletcher does not live on either the top or the bottom floor.
   (not (on-top Fletcher))
   (not (on-bottom Fletcher))
   ;; Miller lives on a higher floor than does Cooper.
   (> Miller Cooper)
   ;; Smith does not live on a floor adjacent to Fletcher's.
   (not (adjacent Smith Fletcher))
   ;; Fletcher does not live on a floor adjacent to Cooper's.
   (assert (not (adjacent Fletcher Cooper))))
  ;; Where does everyone live?
  (printf "Solution:\n")
  (for ([x (sort residents > #:key car)]) (apply printf "  ~a. ~a\n" x)))


use MONKEY-SEE-NO-EVAL;

sub parse_and_solve ($text) {
    my %ids;
    my $expr = (grammar {
        state $c = 0;
        rule TOP { <fact>+ { make join ' && ', $<fact>>>.made } }

        rule fact { <name> (not)? <position>
                    { make sprintf $<position>.made.fmt($0 ??  "!(%s)" !! "%s"),
                                   $<name>.made }
        }
        rule position {
            || on bottom             { make "\@f[%s] == 1"                            }
            || on top                { make "\@f[%s] == +\@f"                         }
            || lower than <name>     { make "\@f[%s] < \@f[{$<name>.made}]"           }
            || higher than <name>    { make "\@f[%s] > \@f[{$<name>.made}]"           }
            || directly below <name> { make "\@f[%s] == \@f[{$<name>.made}] - 1"      }
            || directly above <name> { make "\@f[%s] == \@f[{$<name>.made}] + 1"      }
            || adjacent to <name>    { make "\@f[%s] == \@f[{$<name>.made}] + (-1|1)" }
            || on <ordinal>          { make "\@f[%s] == {$<ordinal>.made}"            }
            || { note "Failed to parse line " ~ +$/.prematch.comb(/^^/); exit 1; }
        }

        token name    { :i <[a..z]>+              { make %ids{~$/} //= $c++ } }
        token ordinal { [1st | 2nd | 3rd | \d+th] { make +$/.match(/(\d+)/)[0]     } }
    }).parse($text).made;

    EVAL 'for [1..%ids.elems].permutations -> @f {
              say %ids.kv.map({ "$^[email protected][$^b]" }) if (' ~ $expr ~ ');
          }'
}

parse_and_solve Q:to/END/;
    Baker not on top
    Cooper not on bottom
    Fletcher not on top
    Fletcher not on bottom
    Miller higher than Cooper
    Smith not adjacent to Fletcher
    Fletcher not adjacent to Cooper
    END


/*REXX program solves the  Dinesman's multiple─dwelling  problem with "natural" wording.*/
names= 'Baker Cooper Fletcher Miller Smith'      /*names of multiple─dwelling tenants.  */
#tenants= words(names)                           /*the number of tenants in the building*/
floors= 5;              top= floors;   bottom= 1 /*floor 1 is the ground (bottom) floor.*/
#= 0                                             /*the number of solutions found so far.*/
     do         @.1=1  for floors                /*iterate through all floors for rules.*/
       do       @.2=1  for floors                /*   "       "     "     "    "    "   */
         do     @.3=1  for floors                /*   "       "     "     "    "    "   */
           do   @.4=1  for floors                /*   "       "     "     "    "    "   */
             do @.5=1  for floors                /*   "       "     "     "    "    "   */
             call set
               do    j=1   for floors-1;  a= @.j /* [↓]  people don't live on same floor*/
                  do k=j+1  to floors            /*see if any people live on same floor.*/
                  if [email protected].k  then iterate @.5    /*Is anyone cohabiting?  Then not valid*/
                  end   /*k*/
               end      /*j*/
             call Waldo                          /* ◄══ where the rubber meets the road.*/
             end        /*@.5*/
           end          /*@.4*/
         end            /*@.3*/
       end              /*@.2*/
     end                /*@.1*/

say 'found '     #       " solution"s(#).        /*display the number of solutions found*/
exit 0                                           /*stick a fork in it,  we're all done. */
/*──────────────────────────────────────────────────────────────────────────────────────*/
set:      do p=1  for #tenants;   call value word(names, p), @.p;   end;       return
s:     if arg(1)=1  then return '';    return "s"        /*a simple pluralizer function.*/
th:    arg x;  x=abs(x);  return word('th st nd rd', 1 +x// 10* (x//100%10\==1)*(x//10<4))
/*──────────────────────────────────────────────────────────────────────────────────────*/
Waldo: if Baker    == top                                          then return
       if Cooper   == bottom                                       then return
       if Fletcher == bottom         |   Fletcher == top           then return
       if Miller   \> Cooper                                       then return
       if Smith    == Fletcher - 1   |   Smith    == Fletcher + 1  then return
       if Fletcher == Cooper   - 1   |   Fletcher == Cooper   + 1  then return
       #= # + 1                                  /* [↑]  "|"  is REXX's "or" comparator.*/
       say;           do p=1  for #tenants;             tenant= word(names, p)
                      say right(tenant, 35)  'lives on the'     @.p || th(@.p)    "floor."
                      end   /*p*/                /* [↑]  "||"  is REXX's concatenation. */
       return                                    /* [↑]  show tenants in order in NAMES.*/


floor1 = "return baker!=cooper and baker!=fletcher and baker!=miller and
          baker!=smith and cooper!=fletcher and cooper!=miller and
          cooper!=smith and fletcher!=miller and fletcher!=smith and
          miller!=smith"
floor2 = "return baker!=4"
floor3 = "return cooper!=0"
floor4 = "return fletcher!=0 and fletcher!=4"
floor5 = "return miller>cooper"
floor6 = "return fabs(smith-fletcher)!=1"
floor7 = "return fabs(fletcher-cooper)!=1"
for baker = 0 to 4
    for cooper = 0 to 4
        for fletcher = 0 to 4
            for miller = 0 to 4
                for smith = 0 to 4
                    if eval(floor2) if eval(floor3) if eval(floor5)
                       if eval(floor4) if eval(floor6) if eval(floor7)
                          if eval(floor1)
                             see "baker lives on floor " + baker + nl
                             see "cooper lives on floor " + cooper + nl
                             see "fletcher lives on floor " + fletcher + nl
                             see "miller lives on floor " + miller + nl
                             see "smith lives on floor " + smith + nl ok ok ok ok ok ok ok
                next
            next
        next
    next
next


def solve( problem )
  lines = problem.split(".")
  names = lines.first.scan( /[A-Z]\w*/ )
  re_names = Regexp.union( names )
  # Later on, search for these keywords (the word "not" is handled separately).
  words = %w(first second third fourth fifth sixth seventh eighth ninth tenth
  bottom top higher lower adjacent)
  re_keywords = Regexp.union( words )

  predicates = lines[1..-2].flat_map do |line|  #build an array of lambda's
    keywords = line.scan( re_keywords )
    name1, name2 = line.scan( re_names )
    keywords.map do |keyword|
      l = case keyword
        when "bottom"   then ->(c){ c.first == name1 }
        when "top"      then ->(c){ c.last == name1 }
        when "higher"   then ->(c){ c.index( name1 ) > c.index( name2 ) }
        when "lower"    then ->(c){ c.index( name1 ) < c.index( name2 ) }
        when "adjacent" then ->(c){ (c.index( name1 ) - c.index( name2 )).abs == 1 }
        else                 ->(c){ c[words.index(keyword)] == name1 }
      end
      line =~ /\bnot\b/ ? ->(c){not l.call(c) } : l  # handle "not"
    end
  end

  names.permutation.detect{|candidate| predicates.all?{|predicate| predicate.(candidate)}}
end


import scala.math.abs

object Dinesman3 extends App {
  val tenants = List("Baker", "Cooper2", "Fletcher4", "Miller", "Smith")
  val (groundFloor, topFloor) = (1, tenants.size)

  /** Rules with related tenants and restrictions*/
  val exclusions =
    List((suggestedFloor0: Map[String, Int]) => suggestedFloor0("Baker") != topFloor,
      (suggestedFloor1: Map[String, Int]) => suggestedFloor1("Cooper2") != groundFloor,
      (suggestedFloor2: Map[String, Int]) => !List(groundFloor, topFloor).contains(suggestedFloor2("Fletcher4")),
      (suggestedFloor3: Map[String, Int]) => suggestedFloor3("Miller") > suggestedFloor3("Cooper2"),
      (suggestedFloor4: Map[String, Int]) => abs(suggestedFloor4("Smith") - suggestedFloor4("Fletcher4")) != 1,
      (suggestedFloor5: Map[String, Int]) => abs(suggestedFloor5("Fletcher4") - suggestedFloor5("Cooper2")) != 1)

  tenants.permutations.map(_ zip (groundFloor to topFloor)).
    filter(p => exclusions.forall(_(p.toMap))).toList match {
      case Nil => println("No solution")
      case xss => {
        println(s"Solutions: ${xss.size}")
        xss.foreach { l =>
          println("possible solution:")
          l.foreach(p => println(f"${p._1}%11s lives on floor number ${p._2}"))
        }
      }
    }
}


func dinesman(problem) {
  var lines = problem.split('.')
  var names = lines.first.scan(/\b[A-Z]\w*/)
  var re_names = Regex(names.join('|'))

  # Later on, search for these keywords (the word "not" is handled separately).
  var words = %w(first second third fourth fifth sixth seventh eighth ninth tenth
                 bottom top higher lower adjacent)
  var re_keywords = Regex(words.join('|'))

  # Build an array of lambda's
  var predicates = lines.ft(1, lines.end-1).map{ |line|
    var keywords = line.scan(re_keywords)
    var (name1, name2) = line.scan(re_names)...

    keywords.map{ |keyword|
      var l = do {
        given(keyword) {
            when ("bottom")   { ->(c) { c.first == name1 } }
            when ("top")      { ->(c) { c.last == name1 } }
            when ("higher")   { ->(c) { c.index(name1) > c.index(name2) } }
            when ("lower")    { ->(c) { c.index(name1) < c.index(name2) } }
            when ("adjacent") { ->(c) { c.index(name1) - c.index(name2) -> abs == 1 } }
            default           { ->(c) { c[words.index(keyword)] == name1 } }
        }
      }
      line ~~ /\bnot\b/ ? func(c) { l(c) -> not } : l;  # handle "not"
    }
  }.flat

  names.permutations { |*candidate|
    predicates.all { |predicate| predicate(candidate) } && return candidate
  }
}


package require Tcl 8.5
package require struct::list

proc dinesmanSolve {floors people constraints} {
    # Search for a possible assignment that satisfies the constraints
    struct::list foreachperm p $floors {
	lassign $p {*}$people
	set found 1
	foreach c $constraints {
	    if {![expr $c]} {
		set found 0
		break
	    }
	}
	if {$found} break
    }
    # Found something, or exhausted possibilities
    if {!$found} {
	error "no solution possible"
    }
    # Generate in "nice" order
    foreach f $floors {
	foreach person $people {
	    if {[set $person] == $f} {
		lappend result $f $person
		break
	    }
	}
    }
    return $result
}


#!/bin/bash

# NAMES is a list of names.  It can be changed as needed.  It can be more than five names, or less.
NAMES=(Baker Cooper Fletcher Miller Smith)

# CRITERIA are the rules imposed on who lives where.  Each criterion must be a valid bash expression
# that will be evaluated.  TOP is the top floor; BOTTOM is the bottom floor.

# The CRITERIA can be changed to create different rules.

CRITERIA=(
  'Baker    != TOP'            # Baker does not live on the top floor
  'Cooper   != BOTTOM'         # Cooper does not live on the bottom floor
  'Fletcher != TOP'            # Fletcher does not live on the top floor
  'Fletcher != BOTTOM'         # and Fletch also does not live on the bottom floor
  'Miller   >  Cooper'         # Miller lives above Cooper
  '$(abs $(( Smith    - Fletcher )) ) > 1'   # Smith and Fletcher are not on adjacent floors
  '$(abs $(( Fletcher - Cooper   )) ) > 1'   # Fletcher and Cooper are not on adjacent floors
)

# Code below here shouldn't need to change to vary parameters
let BOTTOM=0
let TOP=${#NAMES[@]}-1

# Not available as a builtin
abs() { local n=$(( 10#$1 )) ; echo $(( n < 0 ? -n : n )) ; }

# Algorithm we use to iterate over the permutations
# requires that we start with the array sorted lexically
NAMES=($(printf "%s\n" "${NAMES[@]}" | sort))
while true; do
  # set each name to its position in the array
  for (( i=BOTTOM; i<=TOP; ++i )); do
    eval "${NAMES[i]}=$i"
  done

  # check to see if we've solved the problem
  let solved=1
  for criterion in "${CRITERIA[@]}"; do
    if ! eval "(( $criterion ))"; then
      let solved=0
      break
    fi
  done
  if (( solved )); then
    echo "From bottom to top: ${NAMES[@]}"
    break
  fi

  # Bump the names list to the next permutation
  let j=TOP-1
  while (( j >= BOTTOM )) && ! [[ "${NAMES[j]}" < "${NAMES[j+1]}" ]]; do
    let j-=1
  done
  if (( j < BOTTOM )); then break; fi
  let k=TOP
  while (( k > j )) && [[ "${NAMES[k]}" < "${NAMES[j]}" ]]; do
    let k-=1
  done
  if (( k <= j )); then break; fi
  t="${NAMES[j]}"
  NAMES[j]="${NAMES[k]}"
  NAMES[k]="$t"
  for (( k=1; k<=(TOP-j); ++k )); do
    a=BOTTOM+j+k
    b=TOP-k+1
    if (( a < b )); then
      t="${NAMES[a]}"
      NAMES[a]="${NAMES[b]}"
      NAMES[b]="$t"
    fi
  done
done


···
http://rosettacode.org/wiki/Dinesman's_multiple-dwelling_problem
···
import java.util.HashSet

■ Dinesman
  § static

    houses⦂ HashSet⟨String⟩°

    ▶ main
    • args⦂ String[]
      · Baker, Cooper, Fletcher, Miller, and Smith …
      build *StringBuilder°, *StringBuilder "BCFMS"
      ∀ house ∈ houses⦂ String
        if verify house
           System.out.println house.toString°

    ▶ verify⦂ boolean
    • house⦂ String
      · Baker does not live on the top floor.
      return false if house.charAt 4 = 'B'
      · Fletcher does not live on either the top or the bottom floor.
      return false if house.charAt 0 = 'F' or house.charAt 4 = 'F'
      · Cooper does not live on the bottom floor.
      return false if house.charAt 0 = 'C'
      · Miller lives on a higher floor than does Cooper.
      return false if house.indexOf "M" ≤ house.indexOf "C"
      · Smith does not live on a floor adjacent to Fletcher's.
      return false if Math.abs (house.indexOf "S") - (house.indexOf "F") = 1
      · Fletcher does not live on a floor adjacent to Cooper's.
      return false if Math.abs (house.indexOf "F") - (house.indexOf "C") = 1
      return true

    ▶ build
    • house⦂ StringBuilder
    • people⦂ StringBuilder
      if people.length° = 0
         houses.add house.toString°
      else
         ∀ i ∈ 0…people.length°
           person⦂ char: people.charAt i
           house.append person
           people.deleteCharAt i
           build house, people
           people.insert i, person
           house.setLength house.length° - 1


import "/seq" for Lst

var permute // recursive
permute = Fn.new { |input|
    if (input.count == 1) return [input]
    var perms = []
    var toInsert = input[0]
    for (perm in permute.call(input.skip(1).toList)) {
        for (i in 0..perm.count) {
            var newPerm = perm.toList
            newPerm.insert(i, toInsert)
            perms.add(newPerm)
        }
    }
    return perms
}

/* looks for for all possible solutions, not just the first */
var dinesman = Fn.new { |occupants, predicates|
    return permute.call(occupants).where { |perm| predicates.all { |pred| pred.call(perm) } }
}

var occupants = ["Baker", "Cooper", "Fletcher", "Miller", "Smith"]
var predicates = [
    Fn.new { |p| p[-1] != "Baker" },
    Fn.new { |p| p[0]  != "Cooper" },
    Fn.new { |p| p[-1] != "Fletcher" && p[0] != "Fletcher" },
    Fn.new { |p| Lst.indexOf(p, "Miller") > Lst.indexOf(p, "Cooper") },
    Fn.new { |p| (Lst.indexOf(p, "Smith") - Lst.indexOf(p, "Fletcher")).abs > 1 },
    Fn.new { |p| (Lst.indexOf(p, "Fletcher") - Lst.indexOf(p, "Cooper")).abs > 1 }
]

var solutions = dinesman.call(occupants, predicates)
var size = solutions.count
if (size == 0) {
    System.print("No solutions found")
} else {
    var plural = (size == 1) ? "" : "s"
    System.print("%(size) solution%(plural) found, namely:\n")
    for (solution in solutions) {
        var i = 0
        for (name in solution) {
            System.print("Floor %(i+1) -> %(name)")
            i = i + 1
        }
        System.print()
    }
}


include c:\cxpl\codes;
int B, C, F, M, S;
for B:= 1 to 4 do                       \Baker does not live on top (5th) floor
  for C:= 2 to 5 do                     \Cooper does not live on bottom floor
    if C#B then                         \Cooper & Baker live on different floors
      for F:= 2 to 4 do                 \Fletcher doesn't live on top or bottom
        if F#B & F#C & F#C-1 & F#C+1 then \ and she's not adjacent to Cooper
          for M:= 1 to 5 do
            if M#F & M#B & M>C then     \Miller lives above Cooper
              for S:= 1 to 5 do         \Smith is not adjacent to Fletcher
                if S#M & S#F & S#C & S#B & S#F-1 & S#F+1 then       \show
                  [Text(0, "Baker    ");  IntOut(0, B);  CrLf(0);   \all
                   Text(0, "Cooper   ");  IntOut(0, C);  CrLf(0);   \possible
                   Text(0, "Fletcher ");  IntOut(0, F);  CrLf(0);   \solutions
                   Text(0, "Miller   ");  IntOut(0, M);  CrLf(0);
                   Text(0, "Smith    ");  IntOut(0, S);  CrLf(0);
                  ]


var Baker, Cooper, Fletcher, Miller, Smith;  // value == floor
const bottom=1,top=5;	// floors: 1..5
// All live on different floors, enforced by using permutations of floors
//fcn c0{ (Baker!=Cooper!=Fletcher) and (Fletcher!=Miller!=Smith) }
fcn c1{ Baker!=top }
fcn c2{ Cooper!=bottom }
fcn c3{ bottom!=Fletcher!=top }
fcn c4{ Miller>Cooper }
fcn c5{ (Fletcher - Smith).abs() !=1 }
fcn c6{ (Fletcher - Cooper).abs()!=1 }

filters:=T(c1,c2,c3,c4,c5,c6);
dudes:=T("Baker","Cooper","Fletcher","Miller","Smith");  // for reflection
foreach combo in (Utils.Helpers.permuteW([bottom..top].walk())){  // lazy
   dudes.zip(combo).apply2(fcn(nameValue){ setVar(nameValue.xplode()) });
   if(not filters.runNFilter(False)){  // all constraints are True
      vars.println();		       // use reflection to print solution
      break;
   }
}


F digital_root(=n)
   V ap = 0
   L n >= 10
      n = sum(String(n).map(digit -> Int(digit)))
      ap++
   R (ap, n)

L(n) [Int64(627615), 39390, 588225, 393900588225, 55]
   Int64 persistance, root
   (persistance, root) = digital_root(n)
   print(‘#12 has additive persistance #2 and digital root #..’.format(n, persistance, root))


*        Digital root              21/04/2017
DIGROOT  CSECT
         USING  DIGROOT,R13        base register
         B      72(R15)            skip savearea
         DC     17F'0'             savearea
         STM    R14,R12,12(R13)    save previous context
         ST     R13,4(R15)         link backward
         ST     R15,8(R13)         link forward
         LR     R13,R15            set addressability
         LA     R6,1               i=1
       DO WHILE=(C,R6,LE,=A((PG-T)/4))  do i=1 to hbound(t)
         LR     R1,R6                i
         SLA    R1,2                 *4
         L      R10,T-4(R1)          nn=t(i)
         LR     R7,R10               n=nn
         SR     R9,R9                ap=0
       DO WHILE=(C,R7,GE,=A(10))     do while(n>=10)
         SR     R8,R8                  x=0
       DO WHILE=(C,R7,GE,=A(10))       do while(n>=10)
         LR     R4,R7                    n
         SRDA   R4,32                    >>r5
         D      R4,=A(10)                m=n//10
         LR     R7,R5                    n=n/10
         AR     R8,R4                    x=x+m
       ENDDO    ,                      end
         AR     R7,R8                  n=x+n
         LA     R9,1(R9)               ap=ap+1
       ENDDO    ,                    end
         XDECO  R10,XDEC             nn
         MVC    PG+7(10),XDEC+2
         XDECO  R9,XDEC              ap
         MVC    PG+31(3),XDEC+9
         XDECO  R7,XDEC              n
         MVC    PG+41(1),XDEC+11
         XPRNT  PG,L'PG              print
         LA     R6,1(R6)             i++
       ENDDO    ,                  enddo i
         L      R13,4(0,R13)       restore previous savearea pointer
         LM     R14,R12,12(R13)    restore previous context
         XR     R15,R15            rc=0
         BR     R14                exit
T        DC     F'627615',F'39390',F'588225',F'2147483647'
PG       DC     CL80'number=xxxxxxxxxx  persistence=xxx  root=x'
XDEC     DS     CL12
         YREGS
         END    DIGROOT


package Generic_Root is
   type Number is range 0 .. 2**63-1;
   type Number_Array is array(Positive range <>) of Number;
   type Base_Type is range 2 .. 16; -- any reasonable base to write down numb

   generic
      with function "&"(X, Y: Number) return Number;
      -- instantiate with "+" for additive digital roots
      -- instantiate with "*" for multiplicative digital roots
   procedure Compute_Root(N: Number;
                     Root, Persistence: out Number;
                     Base: Base_Type := 10);
   -- computes Root and Persistence of N;

end Generic_Root;


# calculates the digital root and persistance of n #
PROC digital root = ( LONG LONG INT n, REF INT root, persistance )VOID:
     BEGIN
         LONG LONG INT number := ABS n;
         persistance := 0;
         WHILE persistance PLUSAB 1;
               LONG LONG INT digit sum := 0;
               WHILE number > 0
               DO
                   digit sum PLUSAB number MOD 10;
                   number    OVERAB 10
               OD;
               number := digit sum;
               number > 9
         DO
               SKIP
         OD;
         root := SHORTEN SHORTEN number
     END; # digital root #

# calculates and prints the digital root and persistace of number #
PROC print digital root and persistance = ( LONG LONG INT number )VOID:
     BEGIN
         INT    root, persistance;
         digital root( number, root, persistance );
         print( ( whole( number, -15 ), " root: ", whole( root, 0 ), " persistance: ", whole( persistance, -3 ), newline ) )
     END; # print digital root and persistance #

# test the digital root proc #
BEGIN print digital root and persistance(       627615 )
    ; print digital root and persistance(        39390 )
    ; print digital root and persistance(       588225 )
    ; print digital root and persistance( 393900588225 )
END


begin

    % calculates the digital root and persistence of an integer in base 10   %
    % in order to allow for numbers larger than 2^31, the number is passed   %
    % as the lower and upper digits e.g. 393900588225 can be processed by    %
    % specifying upper = 393900, lower = 58825                               %
    procedure findDigitalRoot( integer value  upper, lower
                             ; integer result digitalRoot, persistence
                             ) ;
    begin

        integer procedure sumDigits( integer value n ) ;
        begin
            integer digits, sum;

            digits := abs n;
            sum    := 0;

            while digits > 0
            do begin
                sum    := sum + ( digits rem 10 );
                digits := digits div 10
            end % while digits > 0 % ;

            % result: % sum
        end sumDigits;

        digitalRoot := sumDigits( upper ) + sumDigits( lower );
        persistence := 1;

        while digitalRoot > 9
        do begin
            persistence := persistence + 1;
            digitalRoot := sumDigits( digitalRoot );
        end % while digitalRoot > 9 % ;

    end findDigitalRoot ;

    % calculates and prints the digital root and persistence                 %
    procedure printDigitalRootAndPersistence( integer value upper, lower ) ;
    begin
        integer digitalRoot, persistence;
        findDigitalRoot( upper, lower, digitalRoot, persistence );
        write( s_w := 0  % set field saeparator width for this statement %
             , i_w := 8  % set integer field width for this statement    %
             , upper
             , ", "
             , lower
             , i_w := 2  % change integer field width %
             , ": digital root: "
             , digitalRoot
             , ", persistence: "
             , persistence
             )
    end printDigitalRootAndPersistence ;

    % test the digital root and persistence procedures %
    printDigitalRootAndPersistence(      0, 627615 );
    printDigitalRootAndPersistence(      0,  39390 );
    printDigitalRootAndPersistence(      0, 588225 );
    printDigitalRootAndPersistence( 393900, 588225 )

end.


on digitalroot(N as integer)
	script math
		to sum(L)
			if L = {} then return 0
			(item 1 of L) + sum(rest of L)
		end sum
	end script

	set i to 0
	set M to N

	repeat until M < 10
		set digits to the characters of (M as text)
		set M to math's sum(digits)
		set i to i + 1
	end repeat

	{N:N, persistences:i, root:M}
end digitalroot

digitalroot(627615)


1 GOSUB 430"BASE SETUP
2 FOR E = 0 TO 1 STEP 0
3     GOSUB 7"READ
4     ON E + 1 GOSUB 50, 10
5 NEXT E
6 END

7 READ N$
8 E = N$ = ""
9 RETURN

10 GOSUB 7"READ BASE
20 IF E THEN RETURN
30 BASE = VAL(N$)
40 READ N$

50 GOSUB 100"DIGITAL ROOT
60 GOSUB 420: PRINT " HAS AD";
70 PRINT "DITIVE PERSISTENCE";
80 PRINT " "P" AND DIGITAL R";
90 PRINT "OOT "X$";" : RETURN

REM DIGITAL ROOT OF N$, RETURNS X$ AND P

100 P = 0 : L = LEN(N$)
110 X$ = MID$(N$, 2, L - 1)
120 N = LEFT$(X$, 1) = "-"
130 IF NOT N THEN X$ = N$
140 FOR P = 0 TO 1E38
150     L = LEN(X$)
160     IF L < 2 THEN RETURN
170     GOSUB 200"DIGIT SUM
180     X$ = S$
190 NEXT P : STOP

REM DIGIT SUM OF X$, RETURNS S$

200 S$ = "0"
210 R$ = X$
220 L = LEN(R$)
230 FOR L = L TO 1 STEP -1
240     E$ = "" : V$ = RIGHT$(R$, 1)
250     GOSUB 400 : S = LEN(S$)
260     ON R$ <> "0" GOSUB 300
270     R$ = MID$(R$, 1, L - 1)
280 NEXT L
290 RETURN

REM ADD V TO S$

300 FOR C = V TO 0 STEP 0
310     V$ = RIGHT$(S$, 1)
320     GOSUB 400 : S = S - 1
330     S$ = MID$(S$, 1, S)
340     V = V + C : C = V >= BASE
350     IF C THEN V = V - BASE
360     GOSUB 410 : E$ = V$ + E$
370     IF S THEN NEXT C
380 IF C THEN S$ = "1"
390 S$ = S$ + E$ : RETURN

REM BASE VAL
400 V = V(ASC(V$)) : RETURN

REM BASE STR$
410 V$ = V$(V) : RETURN

REM BASE DISPLAY
420 PRINT N$;
421 IF BASE = 10 THEN RETURN
422 PRINT "("BASE")";
423 RETURN

REM BASE SETUP
430 IF BASE = 0 THEN BASE = 10
440 DIM V(127), V$(35)
450 FOR I = 0 TO 35
460     V = 55 + I - (I < 10) * 7
470     V$(I) = CHR$(V)
480     V(V) = I
490 NEXT I : RETURN

500  DATA627615,39390,588225
510  DATA393900588225
1000 DATA,30
1010 DATADIGITALROOT
63999DATA,


droot: function [num][
    persistence: 0
    until [
        num: sum to [:integer] split to :string num
        persistence: persistence + 1
    ][ num < 10 ]
    return @[num, persistence]
]

loop [627615, 39390, 588225, 393900588225] 'i [
    a: droot i
    print [i "has additive persistence" a\0 "and digital root of" a\1]
]


p := {}
for key, val in [30,1597,381947,92524902,448944221089]
{
    n := val
    while n > 9
    {
        m := 0
        Loop, Parse, n
            m += A_LoopField
        n := m, i := A_Index
    }
    p[A_Index] := [val, n, i]
}

for key, val in p
    Output .= val[1] ": Digital Root = " val[2] ", Additive Persistence = " val[3] "`n"

MsgBox, 524288, , % Output


# syntax: GAWK -f DIGITAL_ROOT.AWK
BEGIN {
    n = split("627615,39390,588225,393900588225,10,199",arr,",")
    for (i=1; i<=n; i++) {
      dr = digitalroot(arr[i],10)
      printf("%12.0f has additive persistence %d and digital root of %d\n",arr[i],p,dr)
    }
    exit(0)
}
function digitalroot(n,b) {
    p = 0 # global
    while (n >= b) {
      p++
      n = digitsum(n,b)
    }
    return(n)
}
function digitsum(n,b,  q,s) {
    while (n != 0) {
      q = int(n / b)
      s += n - q * b
      n = q
    }
    return(s)
}