/*global portviz:false, _:false */
/*
 * 0-1 knapsack solution, recursive, memoized, approximate.
 *
 * credits:
 *
 * the Go implementation here:
 *   http://rosettacode.org/mw/index.php?title=Knapsack_problem/0-1
 *
 * approximation details here:
 *   http://math.mit.edu/~goemans/18434S06/knapsack-katherine.pdf
 */
portviz.knapsack = {};
(function() {
  this.combiner = function(items, weightfn, valuefn) {
    // approximation guarantees result >= (1-e) * optimal
    var _epsilon = 0.01;
    var _p = _.max(_.map(items,valuefn));
    var _k = _epsilon * _p / items.length;

    var _memo = (function(){
      var _mem = {};
      var _key = function(i, w) {
        return i + '::' + w;
      };
      return {
        get: function(i, w) {
          return _mem[_key(i,w)];
        },
        put: function(i, w, r) {
          _mem[_key(i,w)]=r;
          return r;
        }
      };
    })();

    var _m = function(i, w) {

      i = Math.round(i);
      w = Math.round(w);

      if (i < 0 || w === 0) {
        // empty base case
        return {items: [], totalWeight: 0, totalValue: 0};
      }

      var mm = _memo.get(i,w);
      if (!_.isUndefined(mm)) {
        return mm;
      }

      var item = items[i];
      if (weightfn(item) > w) {
        //item does not fit, try the next item
        return _memo.put(i, w, _m(i-1, w));
      }
      // this item could fit.
      // are we better off excluding it?
      var excluded = _m(i-1, w);
      // or including it?
      var included = _m(i-1, w - weightfn(item));
      if (included.totalValue + Math.floor(valuefn(item)/_k) > excluded.totalValue) {
        // better off including it
        // make a copy of the list
        var i1 = included.items.slice();
        i1.push(item);
        return _memo.put(i, w,
          {items: i1,
           totalWeight: included.totalWeight + weightfn(item),
           totalValue: included.totalValue + Math.floor(valuefn(item)/_k)});
      }
      //better off excluding it
      return _memo.put(i,w, excluded);
    };
    return {
      /* one point */
      one: function(maxweight) {
        var scaled = _m(items.length - 1, maxweight);
        return {
          items: scaled.items,
          totalWeight: scaled.totalWeight,
          totalValue: scaled.totalValue * _k
        };
      },
      /* the entire EF */
      ef: function(maxweight, step) {
        return _.map(_.range(0, maxweight+1, step), function(weight) {
          var scaled = _m(items.length - 1, weight);
          return {
            items: scaled.items,
            totalWeight: scaled.totalWeight,
            totalValue: scaled.totalValue * _k
          };
        });
      }
    };
  };
}).apply(portviz.knapsack);

/*global portviz:false, _:false */
/*
 * after rosettacode.org/mw/index.php?title=Knapsack_problem/0-1
 */
var allwants = [
  {name:"map", weight:9, value: 150},
  {name:"compass", weight:13, value: 35},
  {name:"water", weight:153, value: 200},
  {name:"sandwich", weight: 50, value: 160},
  {name:"glucose", weight:15, value: 60},
  {name:"tin", weight:68, value: 45},
  {name:"banana", weight:27, value: 60},
  {name:"apple", weight:39, value: 40},
  {name:"cheese", weight:23, value: 30},
  {name:"beer", weight:52, value: 10},
  {name:"suntan cream", weight:11, value: 70},
  {name:"camera", weight:32, value: 30},
  {name:"T-shirt", weight:24, value: 15},
  {name:"trousers", weight:48, value: 10},
  {name:"umbrella", weight:73, value: 40},
  {name:"waterproof trousers", weight:42, value: 70},
  {name:"waterproof overclothes", weight:43, value: 75},
  {name:"note-case", weight:22, value: 80},
  {name:"sunglasses", weight:7, value: 20},
  {name:"towel", weight:18, value: 12},
  {name:"socks", weight:4, value: 50},
  {name:"book", weight:30, value: 10}
];

var near = function(actual, expected, tolerance) {
  if (expected === 0 && actual === 0) return true;
  if (expected === 0) {
    return Math.abs(expected - actual) / actual < tolerance;
  }
  return Math.abs(expected - actual) / expected < tolerance;
};

test("one knapsack", function() {
  var combiner =
    portviz.knapsack.combiner(allwants,
      function(x){return x.weight;},
      function(x){return x.value;});
  var oneport = combiner.one(400);
  ok(near(oneport.totalValue, 1030, 0.01), "correct total value");
  ok(near(oneport.totalValue, 1030, 0.01), "correct total value");
  equal(oneport.totalWeight, 396, "correct total weight");
});

test("frontier", function() {
  var combiner =
    portviz.knapsack.combiner(allwants,
      function(x){return x.weight;},
      function(x){return x.value;});
  var ef = combiner.ef(400, 1);
  equal(ef.length, 401, "401 because it includes the endpoints");
  ef = combiner.ef(400, 40);
  equal(ef.length, 11, "11 because it includes the endpoints");
  var expectedTotalValue = [
    0,
    330,
    445,
    590,
    685,
    755,
    810,
    860,
    902,
    960,
    1030
  ] ;
  _.each(ef, function(element, index) {
    // 15% error!  bleah!
    ok(near(element.totalValue, expectedTotalValue[index], 0.15),
      'actual ' + element.totalValue + ' expected ' + expectedTotalValue[index]);
  });
  deepEqual(_.pluck(ef, 'totalWeight'), [
    0,
    39,
    74,
    118,
    158,
    200,
    236,
    266,
    316,
    354,
    396
  ]);
  deepEqual(_.map(ef, function(x){return x.items.length;}), [
    0,
    4,
    6,
    7,
    9,
    10,
    10,
    12,
    14,
    11,
    12
   ]);
});

The code determines the optimal combination of items a tourist can carry in his knapsack, given a maximum weight limit of 4kg (400 dag), where each item has a specific weight and value. The goal is to maximize the total value without exceeding the weight limit. The items cannot be divided or reduced.


function Person(name) {

    var candidateIndex = 0;

    this.name = name;
    this.fiance = null;
    this.candidates = [];

    this.rank = function(p) {
        for (i = 0; i < this.candidates.length; i++)
            if (this.candidates[i] === p) return i;
        return this.candidates.length + 1;
    }

    this.prefers = function(p) {
        return this.rank(p) < this.rank(this.fiance);
    }

    this.nextCandidate = function() {
        if (candidateIndex >= this.candidates.length) return null;
        return this.candidates[candidateIndex++];
    }

    this.engageTo = function(p) {
        if (p.fiance) p.fiance.fiance = null;
        p.fiance = this;
        if (this.fiance) this.fiance.fiance = null;
        this.fiance = p;
    }

    this.swapWith = function(p) {
        console.log("%s & %s swap partners", this.name, p.name);
        var thisFiance = this.fiance;
        var pFiance = p.fiance;
        this.engageTo(pFiance);
        p.engageTo(thisFiance);
    }
}

function isStable(guys, gals) {
    for (var i = 0; i < guys.length; i++)
        for (var j = 0; j < gals.length; j++)
            if (guys[i].prefers(gals[j]) && gals[j].prefers(guys[i]))
                return false;
    return true;
}

function engageEveryone(guys) {
    var done;
    do {
        done = true;
        for (var i = 0; i < guys.length; i++) {
            var guy = guys[i];
            if (!guy.fiance) {
                done = false;
                var gal = guy.nextCandidate();
                if (!gal.fiance || gal.prefers(guy))
                    guy.engageTo(gal);
            }
        }
    } while (!done);
}

function doMarriage() {

    var abe  = new Person("Abe");
    var bob  = new Person("Bob");
    var col  = new Person("Col");
    var dan  = new Person("Dan");
    var ed   = new Person("Ed");
    var fred = new Person("Fred");
    var gav  = new Person("Gav");
    var hal  = new Person("Hal");
    var ian  = new Person("Ian");
    var jon  = new Person("Jon");
    var abi  = new Person("Abi");
    var bea  = new Person("Bea");
    var cath = new Person("Cath");
    var dee  = new Person("Dee");
    var eve  = new Person("Eve");
    var fay  = new Person("Fay");
    var gay  = new Person("Gay");
    var hope = new Person("Hope");
    var ivy  = new Person("Ivy");
    var jan  = new Person("Jan");

    abe.candidates  = [abi, eve, cath, ivy, jan, dee, fay, bea, hope, gay];
    bob.candidates  = [cath, hope, abi, dee, eve, fay, bea, jan, ivy, gay];
    col.candidates  = [hope, eve, abi, dee, bea, fay, ivy, gay, cath, jan];
    dan.candidates  = [ivy, fay, dee, gay, hope, eve, jan, bea, cath, abi];
    ed.candidates   = [jan, dee, bea, cath, fay, eve, abi, ivy, hope, gay];
    fred.candidates = [bea, abi, dee, gay, eve, ivy, cath, jan, hope, fay];
    gav.candidates  = [gay, eve, ivy, bea, cath, abi, dee, hope, jan, fay];
    hal.candidates  = [abi, eve, hope, fay, ivy, cath, jan, bea, gay, dee];
    ian.candidates  = [hope, cath, dee, gay, bea, abi, fay, ivy, jan, eve];
    jon.candidates  = [abi, fay, jan, gay, eve, bea, dee, cath, ivy, hope];
    abi.candidates  = [bob, fred, jon, gav, ian, abe, dan, ed, col, hal];
    bea.candidates  = [bob, abe, col, fred, gav, dan, ian, ed, jon, hal];
    cath.candidates = [fred, bob, ed, gav, hal, col, ian, abe, dan, jon];
    dee.candidates  = [fred, jon, col, abe, ian, hal, gav, dan, bob, ed];
    eve.candidates  = [jon, hal, fred, dan, abe, gav, col, ed, ian, bob];
    fay.candidates  = [bob, abe, ed, ian, jon, dan, fred, gav, col, hal];
    gay.candidates  = [jon, gav, hal, fred, bob, abe, col, ed, dan, ian];
    hope.candidates = [gav, jon, bob, abe, ian, dan, hal, ed, col, fred];
    ivy.candidates  = [ian, col, hal, gav, fred, bob, abe, ed, jon, dan];
    jan.candidates  = [ed, hal, gav, abe, bob, jon, col, ian, fred, dan];

    var guys = [abe, bob, col, dan, ed, fred, gav, hal, ian, jon];
    var gals = [abi, bea, cath, dee, eve, fay, gay, hope, ivy, jan];

    engageEveryone(guys);

    for (var i = 0; i < guys.length; i++) {
        console.log("%s is engaged to %s", guys[i].name, guys[i].fiance.name);
    }
    console.log("Stable = %s", isStable(guys, gals) ? "Yes" : "No");
    jon.swapWith(fred);
    console.log("Stable = %s", isStable(guys, gals) ? "Yes" : "No");
}

doMarriage();

"Implement the Gale-Shapley algorithm to solve the Stable Marriage problem. The program takes as input the preferences of ten men and ten women, and outputs a stable set of engagements. It then perturbs this set to form an unstable set of engagements and checks this new set for stability."


(function () {
    'use strict';

    function a(bool) {
        console.log('a -->', bool);

        return bool;
    }

    function b(bool) {
        console.log('b -->', bool);

        return bool;
    }

    var x = a(false) && b(true),
        y = a(true) || b(false),
        z = true ? a(true) : b(false);

  return [x, y, z];
})();

The code defines two functions, 'a' and 'b', both of which accept and return the same boolean value and print their respective names when called. The code then calculates and assigns the values of two equations, using short-circuit evaluation to ensure that function 'b' is only called when necessary. If the programming language does not support short-circuit evaluation, nested 'if' statements are used to achieve the same result. The code demonstrates the concept of short-circuit evaluation in boolean expressions, a feature present in JavaScript since its early versions.


var globalAudioContext = new webkitAudioContext();

function morsecode(text, unit, freq) {
	'use strict';

	// defaults
	unit = unit ? unit : 0.05;
	freq = freq ? freq : 700;
	var cont = globalAudioContext;
	var time = cont.currentTime;

	// morsecode
	var code = {
		a: '._',    b: '_...',  c: '_._.',  d: '_..',   e: '.',     f: '.._.',
		g: '__.',   h: '....',  i: '..',    j: '.___',  k: '_._',   l: '._..',
		m: '__',    n: '_.',    o: '___',   p: '.__.',  q: '__._',  r: '._.',
		s: '...',   t: '_',     u: '.._',   v: '..._',  w: '.__',   x: '_.._',
		y: '_.__',  z: '__..',  0: '_____', 1: '.____', 2: '..___', 3: '...__',
		4: '...._', 5: '.....', 6: '_....', 7: '__...', 8: '___..', 9: '____.'
	};

	// generate code for text
	function makecode(data) {
		for (var i = 0; i <= data.length; i ++) {
			var codedata = data.substr(i, 1).toLowerCase();
			codedata = code[codedata];
			// recognised character
			if (codedata !== undefined) {
				maketime(codedata);
			}
			// unrecognised character
			else {
				time += unit * 7;
			}
		}
	}

	// generate time for code
	function maketime(data) {
		for (var i = 0; i <= data.length; i ++) {
			var timedata = data.substr(i, 1);
			timedata = (timedata === '.') ? 1 : (timedata === '_') ? 3 : 0;
			timedata *= unit;
			if (timedata > 0) {
				maketone(timedata);
				time += timedata;
				// tone gap
				time += unit * 1;
			}
		}
		// char gap
		time += unit * 2;
	}

	// generate tone for time
	function maketone(data) {
		var start = time;
		var stop = time + data;
		// filter: envelope the tone slightly
		gain.gain.linearRampToValueAtTime(0, start);
		gain.gain.linearRampToValueAtTime(1, start + (unit / 8));
		gain.gain.linearRampToValueAtTime(1, stop - (unit / 16));
		gain.gain.linearRampToValueAtTime(0, stop);
	}

	// create: oscillator, gain, destination
	var osci = cont.createOscillator();
	osci.frequency.value = freq;
	var gain = cont.createGainNode();
	gain.gain.value = 0;
	var dest = cont.destination;
	// connect: oscillator -> gain -> destination
	osci.connect(gain);
	gain.connect(dest);
	// start oscillator
	osci.start(time);

	// begin encoding: text -> code -> time -> tone
	makecode(text);

	// return web audio context for reuse / control
	return cont;
}

morsecode('Hello World');

The code translates a given string into Morse code, handles unknown characters, and outputs the Morse code as audible tones through an audio device using the Web Audio API. It is divided into three modules: character to Morse code translation, Morse code timing creation, and tone generation based on the timings.


ES5[edit]
Imperative[edit]

var blocks = "BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM";

function CheckWord(blocks, word) {
   // Makes sure that word only contains letters.
   if(word !== /([a-z]*)/i.exec(word)[1]) return false;
   // Loops through each character to see if a block exists.
   for(var i = 0; i < word.length; ++i)
   {
      // Gets the ith character.
      var letter = word.charAt(i);
      // Stores the length of the blocks to determine if a block was removed.
      var length = blocks.length;
      // The regexp gets constructed by eval to allow more browsers to use the function.
      var reg = eval("/([a-z]"+letter+"|"+letter+"[a-z])/i");
      // This does the same as above, but some browsers do not support...
      //var reg = new RegExp("([a-z]"+letter+"|"+letter+"[a-z])", "i");
      // Removes all occurrences of the match.
      blocks = blocks.replace(reg, "");
      // If the length did not change then a block did not exist.
      if(blocks.length === length) return false;
   }
   // If every character has passed then return true.
   return true;
};

var words = [
   "A",
   "BARK",
   "BOOK",
   "TREAT",
   "COMMON",
   "SQUAD",
   "CONFUSE"
];

for(var i = 0;i<words.length;++i)
   console.log(words[i] + ": " + CheckWord(blocks, words[i]));

A: true
BARK: true
BOOK: false
TREAT: true
COMMON: false
SQUAD: true
CONFUSE: true

Functional[edit]
(function (strWords) {

    var strBlocks =
        'BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM',
        blocks = strBlocks.split(' ');

    function abc(lstBlocks, strWord) {
        var lngChars = strWord.length;

        if (!lngChars) return [];

        var b = lstBlocks[0],
            c = strWord[0];

        return chain(lstBlocks, function (b) {
            return (b.indexOf(c.toUpperCase()) !== -1) ? [
                (b + ' ').concat(
                    abc(removed(b, lstBlocks), strWord.slice(1)))
            ] : [];
        })
    }

    // Monadic bind (chain) for lists
    function chain(xs, f) {
        return [].concat.apply([], xs.map(f));
    }

    // a -> [a] -> [a]
    function removed(x, xs) {
        var h = xs.length ? xs[0] : null,
            t = h ? xs.slice(1) : [];

        return h ? (
            h === x ? t : [h].concat(removed(x, t))
        ) : [];
    }

    function solution(strWord) {
        var strAttempt = abc(blocks, strWord)[0].split(',')[0];

        // two chars per block plus one space -> 3
        return strWord + ((strAttempt.length === strWord.length * 3) ?
            ' -> ' + strAttempt : ': [no solution]');
    }

    return strWords.split(' ').map(solution).join('\n');

})('A bark BooK TReAT COMMON squAD conFUSE');

The code defines a function that determines if a given word can be spelled using a specific collection of ABC blocks. Each block contains two letters and can only be used once. The function is case-insensitive. It also includes examples of the function's usage with seven different words. The method utilizes regular expressions and the string replace function for better compatibility with older browsers.


for (var n = 0; n < 1e14; n++) { // arbitrary limit that's not too big
    document.writeln(n.toString(8)); // not sure what's the best way to output it in JavaScript
}

generate a sequential count in octal, starting from zero and incrementing by one on each line until the program is terminated or the maximum numeric type value is reached.


function swap(arr) {
  var tmp = arr[0];
  arr[0] = arr[1];
  arr[1] = tmp;
}

function swap(aName, bName) {
  eval('(function(){ arguments[0] = aName; aName = bName; bName = arguments[0] })()'
    .replace(/aName/g, aName)
    .replace(/bName/g, bName)
  )
}
var x = 1
var y = 2
swap('x', 'y')

function swap(a, b) {
  var tmp = window[a];
  window[a] = window[b];
  window[b] = tmp;
}
var x = 1;
var y = 2;
swap('x', 'y');

const arr = [1, 2, 3, 4, 5];
[arr[0], arr[1]] = [arr[1], arr[0]]

implement a generic swap function or operator that can exchange the values of two variables or storage places, regardless of their types. In statically typed languages, the function describes how the language provides genericity. The variables should have a mutually compatible type to avoid type violation. The function also addresses issues in programming language semantics, including difficulties in generic programming and destructive operations. In JavaScript, the function can swap values by wrapping the variables in an object or array. It also provides a metaprogramming solution using code generation and eval. The function can also swap array items using destructing assignment.


function isPalindrome(str) {
  return str === str.split("").reverse().join("");
}

console.log(isPalindrome("ingirumimusnocteetconsumimurigni"));

var isPal = str => str === str.split("").reverse().join("");

(() => {

    // isPalindrome :: String -> Bool
    const isPalindrome = s => {
        const cs = filter(c => ' ' !== c, s.toLocaleLowerCase());
        return cs.join('') === reverse(cs).join('');
    };

    // TEST -----------------------------------------------
    const main = () =>
        isPalindrome(
            'In girum imus nocte et consumimur igni'
        )

    // GENERIC FUNCTIONS ----------------------------------

    // filter :: (a -> Bool) -> [a] -> [a]
    const filter = (f, xs) => (
        'string' !== typeof xs ? (
            xs
        ) : xs.split('')
    ).filter(f);

    // reverse :: [a] -> [a]
    const reverse = xs =>
        'string' !== typeof xs ? (
            xs.slice(0).reverse()
        ) : xs.split('').reverse().join('');

    // MAIN ---
    return main();
})();

implement a function to check if a given sequence of characters is a palindrome. It supports Unicode characters and also detects inexact palindromes by ignoring white-space, punctuation, and case sensitivity. The function may also reverse a string and be used to test other functions.


Works with: JScript
var shell = new ActiveXObject("WScript.Shell");
var env = shell.Environment("PROCESS");
WScript.echo('SYSTEMROOT=' + env.item('SYSTEMROOT'));

demonstrate how to access a process's environment variables such as PATH, HOME, or USER in a Unix system using JavaScript, relying on the host environment for access.


/**
 * @param {bigint} n
 * @param {bigint} x
 * @param {bigint} y
 * @returns {bigint}
 */
function F(n, x, y) {
  if (n === 0) {
    return x + y;
  }

  if (y === 0) {
    return x;
  }

  return F(n - 1, F(n, x, y - 1), F(n, x, y - 1) + y);
}

Implement the Sudan function, a non-primitive recursive function. The function takes two arguments, x and y, and returns a value based on the defined recursive rules.


% push( ELEMENT, STACK, NEW )
% True if NEW is [ELEMENT|STACK]
push(ELEMENT,STACK,[ELEMENT|STACK]).

% pop( STACK, TOP, NEW )
% True if TOP and NEW are head and tail, respectively, of STACK
pop([TOP|STACK],TOP,STACK).

% empty( STACK )
% True if STACK is empty
empty([]).

implement a stack with basic operations such as push, pop, and empty. The stack follows a last in, first out (LIFO) access policy. The topmost element can be accessed without modifying the stack. The stack can be used for resource management, implementing local variables in recursive subprograms, and in various algorithms.


The code generates the nth Fibonacci number using either an iterative or recursive approach. It optionally supports negative numbers by inversely applying the Fibonacci formula. The code also implements a time/space tradeoff to improve performance for larger values of N by storing interim N/Value pairs for quicker future use. It also includes a generator function that can generate all Fibonacci numbers in sequence without requiring any bound input variables.


findall[edit]
evens(D, Es) :- findall(E, (member(E, D), E mod 2 =:= 0), Es).

?- evens([1,2,3,4,5,6,7,8,9,10],E).
E = [2, 4, 6, 8, 10]
Anonymous functions[edit]

?- use_module(library(lambda)).
true.

?- include((\X^(X mod 2 =:= 0)), [1,2,3,4,5,6,7,8,9], L).
L = [2,4,6,8].
filter and anonymous functions[edit]

:- use_module(lambda).

%% filter(Pred, LstIn, LstOut)
%%
filter(_Pre, [], []).

filter(Pred, [H|T], L) :-
	filter(Pred, T, L1),
	(   call(Pred,H) -> L = [H|L1]; L = L1).

 ?- filter(\X^(X mod 2 =:= 0), [1,2,3,4,5,6,7,8,9], L).
L = [2,4,6,8] .

The code selects specific elements from an array to create a new array in a generic manner. It specifically filters out all even numbers from an array. Optionally, it can also modify the original array instead of creating a new one. The code is compatible with SWI-Prolog and the lambda module by Ulrich Neumerkel.


Works with: SWI Prolog version 7
substring_task(Str, N, M, Char, SubStr) :-
    sub_string(Str, N, M, _, Span),
    sub_string(Str, N, _, 0, ToEnd),
    sub_string(Str, 0, _, 1, MinusLast),
    string_from_substring_to_m(Str, Char, M, FromCharToMth),
    string_from_substring_to_m(Str, SubStr, M, FromSubToM),
    maplist( writeln,
            [ 'from n to m ':Span,
              'from n to end ': ToEnd,
              'string minus last char ': MinusLast,
              'form known char to m ': FromCharToMth,
              'from known substring to m ': FromSubToM ]).

string_from_substring_to_m(String, Sub, M, FromSubToM) :-
    sub_string(String, Before, _, _, Sub),
    sub_string(String, Before, M, _, FromSubToM).

?- substring_task("abcdefghijk", 2, 4, "d", "ef").
from n to m :cdef
from n to end :cdefghijk
string minus last char :abcdefghij
form known char to m :defg
from known substring to m :efgh
true

The code extracts substrings from a given string in various ways: starting from a specified character index and of a certain length, starting from a specified character index to the end of the string, excluding the last character of the string, starting from a known character or substring within the string and of a specified length. The code supports any valid Unicode code point and works with logical characters, not 8-bit or 16-bit code units. It is not designed to handle all Unicode characters for other encodings like 8-bit ASCII or EUC-JP.


Works with: SWI Prolog
reverse("abcd", L), string_to_list(S,L).

The code takes an input string and reverses its characters. It also ensures the preservation of Unicode combining characters during the reversal process. For instance, "asdf" is reversed to "fdsa" and "as⃝df̅" is reversed to "f̅ds⃝a". The main functionality is encapsulated in the reverse/2 predicate.


    rpath([target|reversed_path], distance)

   - arbitrarily selects a node (Qi) neighboring origin (o), and for that node
   - if o->Qi is the shortest known path:
       - update path and distance
       - traverse Qi
   - if o->Qi is not the shortest, select the next node.

   - We use this list to ensure that we do not loop endlessly.
   - This path is recorded as the shortest if the distance is indeed shorter than a known path.
   - Leaf nodes in the traversal tree are processed completely before the origin node processing
     is completed.
     - This implies that the first stage in our algorithm involves allocating each node
       in the traversal tree a path and 'shortest known distance from origin' value.
     - ...Which is arguably better than assigning an initial 'infinite distance' value.

%___________________________________________________________________________

:-dynamic
	rpath/2.      % A reversed path

edge(a,b,7).
edge(a,c,9).
edge(b,c,10).
edge(b,d,15).
edge(c,d,11).
edge(d,e,6).
edge(a,f,14).
edge(c,f,2).
edge(e,f,9).

path(From,To,Dist) :- edge(To,From,Dist).
path(From,To,Dist) :- edge(From,To,Dist).

shorterPath([H|Path], Dist) :-		       % path < stored path? replace it
	rpath([H|T], D), !, Dist < D,          % match target node [H|_]
	retract(rpath([H|_],_)),
	writef('%w is closer than %w\n', [[H|Path], [H|T]]),
	assert(rpath([H|Path], Dist)).
shorterPath(Path, Dist) :-		       % Otherwise store a new path
	writef('New path:%w\n', [Path]),
	assert(rpath(Path,Dist)).

traverse(From, Path, Dist) :-		    % traverse all reachable nodes
	path(From, T, D),		    % For each neighbor
	not(memberchk(T, Path)),	    %	which is unvisited
	shorterPath([T,From|Path], Dist+D), %	Update shortest path and distance
	traverse(T,[From|Path],Dist+D).	    %	Then traverse the neighbor

traverse(From) :-
	retractall(rpath(_,_)),           % Remove solutions
	traverse(From,[],0).              % Traverse from origin
traverse(_).

go(From, To) :-
	traverse(From),                   % Find all distances
	rpath([To|RPath], Dist)->         % If the target was reached
	  reverse([To|RPath], Path),      % Report the path and distance
	  Distance is round(Dist),
	  writef('Shortest path is %w with distance %w = %w\n',
	       [Path, Dist, Distance]);
	writef('There is no route from %w to %w\n', [From, To]).

?- go(a,e).
New path:[b,a]
New path:[c,b,a]
New path:[d,c,b,a]
New path:[e,d,c,b,a]
New path:[f,e,d,c,b,a]
[f,c,b,a] is closer than [f,e,d,c,b,a]
[e,f,c,b,a] is closer than [e,d,c,b,a]
[d,b,a] is closer than [d,c,b,a]
[c,a] is closer than [c,b,a]
[d,c,a] is closer than [d,b,a]
[e,d,c,a] is closer than [e,f,c,b,a]
[f,c,a] is closer than [f,c,b,a]
[e,f,c,a] is closer than [e,d,c,a]
Shortest path is [a,c,f,e] with distance 0+9+2+9 = 20
true.

implement Dijkstra's algorithm for finding the shortest path in a graph with non-negative edge path costs. The algorithm takes a directed and weighted graph, represented by an adjacency matrix or list and a start node, as input. It outputs a set of edges depicting the shortest path to each reachable node from the start node. The code also includes functionality to interpret the output and display the shortest path from the start node to specified nodes.


mersenne_factor(P, F) :-
    prime(P),
    once((
        between(1, 100_000, K),  % Fail if we can't find a small factor
        Q is 2*K*P + 1,
        test_factor(Q, P, F))).

test_factor(Q, P, prime) :- Q*Q > (1 << P - 1), !.
test_factor(Q, P, Q) :-
    R is Q /\ 7, member(R, [1, 7]),
    prime(Q),
    powm(2, P, Q) =:= 1.

wheel235(L) :-
   W = [4, 2, 4, 2, 4, 6, 2, 6 | W],
   L = [1, 2, 2 | W].

prime(N) :-
   N >= 2,
   wheel235(W),
   prime(N, 2, W).

prime(N, D, _) :- D*D > N, !.
prime(N, D, [A|As]) :-
    N mod D =\= 0,
    D2 is D + A, prime(N, D2, As).

implement a method to find a factor of a Mersenne number (in this case, M929). The method uses efficient algorithms to determine if a number divides 2P-1, including a self-implemented modPow operation. It also incorporates properties of Mersenne numbers to refine the process, such as the form of any factor q of 2P-1 and the conditions that q must meet. The method stops when 2kP+1 > sqrt(N). It only works on Mersenne numbers where P is prime.


:- use_module(library(lists)).

set :-
	A = [2, 4, 1, 3],
	B = [5, 2, 3, 2],
	(   is_set(A) -> format('~w is a set~n', [A])
	;   format('~w is not a set~n', [A])),
	(   is_set(B) -> format('~w is a set~n', [B])
	;   format('~w is not a set~n', [B])),

	% create a set from a list

	list_to_set(B, BS),
	(   is_set(BS) -> format('~nCreate a set from a list~n~w is a set~n', [BS])
	;   format('~w is not a set~n', [BS])),

	intersection(A, BS, I),
	format('~n~w intersection ~w => ~w~n', [A, BS, I]),
	union(A, BS, U),
	format('~w union ~w => ~w~n', [A, BS, U]),
	difference(A, BS, D),
	format('~w difference ~w => ~w~n', [A, BS, D]),

	X = [1,2],
	(   subset(X, A) -> format('~n~w is a subset of ~w~n', [X, A])
	;   format('~w is not a subset of ~w~n', [X, A])),
	Y = [1,5],
	(   subset(Y, A) -> format('~w is a subset of ~w~n', [Y, A])
	;   format('~w is not a subset of ~w~n', [Y, A])),
	Z = [1, 2, 3, 4],
	(  equal(Z, A) -> format('~n~w is equal to ~w~n', [Z, A])
	;   format('~w is not equal to ~w~n', [Z, A])),
	T = [1, 2, 3],
	(  equal(T, A) -> format('~w is equal to ~w~n', [T, A])
	;   format('~w is not equal to ~w~n', [T, A])).

% compute difference of sets
difference(A, B, D) :-
	exclude(member_(B), A, D).

member_(L, X) :-
	member(X, L).

equal([], []).
equal([H1 | T1], B) :-
	select(H1, B, B1),
	equal(T1, B1).

The code demonstrates various set operations such as set creation, checking if an element belongs to a set, union, intersection, difference, subset, and equality of two sets. It also optionally shows other set operations and modifications on a mutable set. The set is implemented using an associative array, binary search tree, hash table, or binary bits. The code works with SWI-Prolog's standard library ordsets, which treats sets as ordered lists of unique elements.


main() :-
    christmas_days_falling_on_sunday(2011, 2121, SundayList),
    writeln(SundayList).

christmas_days_falling_on_sunday(StartYear, EndYear, SundayList) :-
    numlist(StartYear, EndYear, YearRangeList),
    include(is_christmas_day_a_sunday, YearRangeList, SundayList).

is_christmas_day_a_sunday(Year) :-
    Date = date(Year, 12, 25),
    day_of_the_week(Date, DayOfTheWeek),
    DayOfTheWeek == 7.

The code determines the years between 2008 and 2121 where Christmas (25th December) falls on a Sunday by using standard date handling libraries. It also compares the calculated dates with the outputs of other languages to identify any discrepancies due to issues like overflow in date/time representation similar to y2k problems. The code is compatible with SWI-Prolog.


uniq(Data,Uniques) :- sort(Data,Uniques).

?- uniq([1, 2, 3, 2, 3, 4],Xs).
Xs = [1, 2, 3, 4]

member1(X,[H|_]) :- X==H,!.
member1(X,[_|T]) :- member1(X,T).

distinct([],[]).
distinct([H|T],C) :- member1(H,T),!, distinct(T,C).
distinct([H|T],[H|C]) :- distinct(T,C).

?- distinct([A, A, 1, 2, 3, 2, 3, 4],Xs).
Xs = [A, 1, 2, 3, 4]

"Implement a function to remove duplicate elements from an array. This can be achieved through three approaches: 1) Using a hash table to eliminate duplicates with a complexity of O(n) on average and O(n2) in the worst case. 2) Sorting the elements and removing consecutive duplicates with a complexity of O(n log n). 3) Iterating through the list, checking for duplicate elements and discarding them with a complexity of O(n2)."


qsort( [], [] ).
qsort( [H|U], S ) :- splitBy(H, U, L, R), qsort(L, SL), qsort(R, SR), append(SL, [H|SR], S).

% splitBy( H, U, LS, RS )
% True if LS = { L in U | L <= H }; RS = { R in U | R > H }
splitBy( _, [], [], []).
splitBy( H, [U|T], [U|LS], RS ) :- U =< H, splitBy(H, T, LS, RS).
splitBy( H, [U|T], LS, [U|RS] ) :- U  > H, splitBy(H, T, LS, RS).

implement the Quicksort algorithm to sort an array or list of elements. The algorithm works by choosing a pivot element and dividing the rest of the elements into two partitions - one with elements less than the pivot and the other with elements greater than the pivot. It then recursively sorts these partitions and joins them with the pivot to get the sorted array. The codes also include an optimized version of Quicksort that works in place by swapping elements within the array to avoid memory allocation of more arrays. The pivot selection method is not specified.


Works with: SWI-Prolog version 6
display_date :-
    get_time(Time),
    format_time(atom(Short), '%Y-%M-%d',      Time),
    format_time(atom(Long),  '%A, %B %d, %Y', Time),
    format('~w~n~w~n', [Short, Long]).

display the current date in two formats: "2007-11-23" and "Friday, November 23, 2007".


Logical (cut-free) Definition[edit]

powerset(X,Y) :- bagof( S, subseq(S,X), Y).

subseq( [], []).
subseq( [], [_|_]).
subseq( [X|Xs], [X|Ys] ) :- subseq(Xs, Ys).
subseq( [X|Xs], [_|Ys] ) :- append(_, [X|Zs], Ys), subseq(Xs, Zs).

The code implements a function that takes a set S as input and generates the power set of S. It uses either a built-in set type or a custom-defined set type with necessary operations. The power set includes all subsets of the original set, including the empty set and the set itself. The code also demonstrates the handling of edge cases, such as the power set of an empty set and the power set of a set containing only the empty set. It uses the predicate powerset(X,Y) to represent "Y is the power set of X" and subseq(X,Y) to check if X is a subsequence of Y. The implementation is efficient and logical.


The code defines a function that takes a positive integer as an input and returns its equivalent in Roman numerals. It handles each digit separately, starting from the leftmost digit and ignoring zeroes. It also ensures compatibility with both Roman to Arabic and Arabic to Roman conversions using the clpfd library.


Works with: SWI Prolog

singleassignment:-
    functor(Array,array,100), % create a term with 100 free Variables as arguments
                              % index of arguments start at 1
    arg(1 ,Array,a),          % put an a at position 1
    arg(12,Array,b),          % put an b at position 12
    arg(1 ,Array,Value1),     % get the value at position 1
    print(Value1),nl,         % will print Value1 and therefore a followed by a newline
    arg(4 ,Array,Value2),     % get the value at position 4 which is a free Variable
    print(Value2),nl.         % will print that it is a free Variable followed by a newline

destructive:-
    functor(Array,array,100), % create a term with 100 free Variables as arguments
                              % index of arguments start at 1
    setarg(1 ,Array,a),       % put an a at position 1
    setarg(12,Array,b),       % put an b at position 12
    setarg(1, Array,c),       % overwrite value at position 1 with c
    arg(1 ,Array,Value1),     % get the value at position 1
    print(Value1),nl.         % will print Value1 and therefore c followed by a newline

listvariant:-
    length(List,100),          % create a list of length 100
    nth1(1 ,List,a),           % put an a at position 1 , nth1/3 uses indexing from 1, nth0/3 from 0
    nth1(12,List,b),           % put an b at position 3
    append(List,[d],List2),    % append an d at the end , List2 has 101 elements
    length(Add,10),            % create a new list of length 10
    append(List2,Add,List3),   % append 10 free variables to List2 , List3 now has 111 elements
    nth1(1 ,List3,Value),      % get the value at position 1
    print(Value),nl.           % will print out a

demonstrate the basic syntax of arrays in the given programming language. The codes create an array, assign a value to it, and retrieve an element from it. The codes also showcase the use of both fixed-length and dynamic arrays, including the process of pushing a value into the array. The codes further illustrate the use of Prolog Terms as array structures, utilizing functor/3 for array creation and arg/3 for nondestructive retrieval and setting of elements. Additionally, setarg/3 is used for destructive setting of an array element, mimicking the common practice in most other programming languages. The codes also demonstrate the use of lists as arrays.


% main predicate, find and print closest point
do_find_closest_points(Points) :-
	points_closest(Points, points(point(X1,Y1),point(X2,Y2),Dist)),
	format('Point 1 : (~p, ~p)~n', [X1,Y1]),
	format('Point 1 : (~p, ~p)~n', [X2,Y2]),
	format('Distance: ~p~n', [Dist]).

% Find the distance between two points
distance(point(X1,Y1), point(X2,Y2), points(point(X1,Y1),point(X2,Y2),Dist)) :-
	Dx is X2 - X1,
	Dy is Y2 - Y1,
	Dist is sqrt(Dx * Dx + Dy * Dy).

% find the closest point that relatest to another point
point_closest(Points, Point, Closest) :-
	select(Point, Points, Remaining),
	maplist(distance(Point), Remaining, PointList),
	foldl(closest, PointList, 0, Closest).

% find the closest point/dist pair for all points
points_closest(Points, Closest) :-
	maplist(point_closest(Points), Points, ClosestPerPoint),
	foldl(closest, ClosestPerPoint, 0, Closest).

% used by foldl to get the lowest point/distance combination
closest(points(P1,P2,Dist), 0, points(P1,P2,Dist)).
closest(points(_,_,Dist), points(P1,P2,Dist2), points(P1,P2,Dist2)) :-
	Dist2 < Dist.
closest(points(P1,P2,Dist), points(_,_,Dist2), points(P1,P2,Dist)) :-
	Dist =< Dist2.

do_find_closest_points([
    point(0.654682, 0.925557),
    point(0.409382, 0.619391),
    point(0.891663, 0.888594),
    point(0.716629, 0.996200),
    point(0.477721, 0.946355),
    point(0.925092, 0.818220),
    point(0.624291, 0.142924),
    point(0.211332, 0.221507),
    point(0.293786, 0.691701),
    point(0.839186, 0.728260)
]).

The code provides two solutions to the closest pair of points problem in a two-dimensional plane. The first solution uses a brute-force algorithm with a time complexity of O(n^2) to find the two points with the minimum distance between them. The second solution uses a recursive divide and conquer approach with a time complexity of O(n log n) to find the closest pair of points. The points are sorted by their x and y coordinates in ascending order. The code is tested with a list of points in SWI-Prolog.


% create a list
L = [a,b,c,d],

% prepend to the list
L2 = [before_a|L],

% append to the list
append(L2, ['Hello'], L3),

% delete from list
exclude(=(b), L3, L4).

L = [a, b, c, d],
L2 = [before_a, a, b, c, d],
L3 = [before_a, a, b, c, d, 'Hello'],
L4 = [before_a, a, c, d, 'Hello'].

% create an empty dict call 'point'
D1 = point{},

% add a value
D2 = D1.put(x, 20).put(y, 30).put(z, 20),

% update a value
D3 = D2.put([x=25]),

% remove a value
del_dict(z, D3, _, D4),

% access a value randomly
format('x = ~w, y = ~w~n', [D4.x, D4.y]).

x = 25, y = 30
D1 = point{},
D2 = point{x:20, y:30, z:20},
D3 = point{x:25, y:30, z:20},
D4 = point{x:25, y:30}.

create a collection and add a few values to it. The code also demonstrates how to use different types of collections in statically-typed languages. It also includes examples of using Dicts in SWI-Prolog, which can be accessed, added, and removed in an immutable way.


:- use_module(library(simplex)).

% tuples (name, Explantion, Value, weights, volume).
knapsack :-
	L =[(	panacea, 'Incredible healing properties', 3000,	0.3,	0.025),
	    (	ichor,   'Vampires blood',                1800,	0.2,	0.015),
	    (	gold ,	 'Shiney shiney',	          2500,	2.0,	0.002)],

	 gen_state(S0),
	 length(L, N),
	 numlist(1, N, LN),

	 % to get statistics
	 time((create_constraint_N(LN, L, S0, S1, [], LVa, [], LW, [], LVo),
	       constraint(LW =< 25.0, S1, S2),
	       constraint(LVo =< 0.25, S2, S3),
	       maximize(LVa, S3, S4)
	      )),

	% we display the results
	compute_lenword(L, 0, Len),
	sformat(A0, '~~w~~t~~~w|', [3]),
	sformat(A1, '~~w~~t~~~w|', [Len]),
	sformat(A2, '~~t~~w~~~w|', [10]),
	sformat(A3, '~~t~~2f~~~w|', [10]),
	sformat(A4, '~~t~~3f~~~w|', [10]),
	sformat(A33, '~~t~~w~~~w|', [10]),
	sformat(A44, '~~t~~w~~~w|', [10]),

	sformat(W0, A0, ['Nb']),
	sformat(W1, A1, ['Items']),
	sformat(W2, A2, ['Value']),
	sformat(W3, A33, ['Weigth']),
	sformat(W4, A44, ['Volume']),
	format('~w~w~w~w~w~n', [W0, W1,W2,W3,W4]),

	print_results(S4, A0, A1, A2, A3, A4, L, LN, 0, 0, 0).

create_constraint_N([], [], S, S, LVa, LVa, LW, LW, LVo, LVo).

create_constraint_N([HN|TN], [(_, _,Va, W, Vo) | TL], S1, SF, LVa, LVaF, LW, LWF, LVo, LVoF) :-
	constraint(integral(x(HN)), S1, S2),
	constraint([x(HN)] >= 0, S2, S3),
	create_constraint_N(TN, TL, S3, SF,
			    [Va * x(HN) | LVa], LVaF,
			    [W * x(HN) | LW], LWF,
			    [Vo * x(HN) | LVo], LVoF).

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
compute_lenword([], N, N).
compute_lenword([(Name, _, _, _, _)|T], N, NF):-
	atom_length(Name, L),
	(   L > N -> N1 = L; N1 = N),
	compute_lenword(T, N1, NF).

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
print_results(_S, A0, A1, A2, A3, A4, [], [], VaM, WM, VoM) :-
	sformat(W0, A0, [' ']),
	sformat(W1, A1, [' ']),
	sformat(W2, A2, [VaM]),
	sformat(W3, A3, [WM]),
	sformat(W4, A4, [VoM]),
	format('~w~w~w~w~w~n', [W0, W1,W2,W3,W4]).

print_results(S, A0, A1, A2, A3, A4, [(Name, _, Va, W, Vo)|T], [N|TN], Va1, W1, Vo1) :-
	variable_value(S, x(N), X),
	(   X = 0 -> Va1 = Va2, W1 = W2, Vo1 = Vo2
	;
	    sformat(S0, A0, [X]),
	    sformat(S1, A1, [Name]),
	    Vatemp is X * Va,
	    Wtemp is X * W,
	    Votemp is X * Vo,
	    sformat(S2, A2, [Vatemp]),
	    sformat(S3, A3, [Wtemp]),
	    sformat(S4, A4, [Votemp]),
	    format('~w~w~w~w~w~n', [S0,S1,S2,S3,S4]),
	    Va2 is Va1 + Vatemp,
	    W2 is W1 + Wtemp,
	    Vo2 is Vo1 + Votemp ),
	print_results(S, A0, A1, A2, A3, A4, T, TN, Va2, W2, Vo2).

 ?- knapsack.
% 145,319 inferences, 0.078 CPU in 0.079 seconds (99% CPU, 1860083 Lips)
Nb Items       Value    Weigth    Volume
15 ichor       27000      3.00     0.225
11 gold        27500     22.00     0.022
               54500     25.00     0.247
true

determine the maximum value of items a traveler can carry in his knapsack, given the weight and volume constraints, and the value, weight, and volume of each item. The solution provides one of the four possible combinations that yield the maximum value.


example :-
  between(1,10,Val), write(Val), Val<10, write(', '), fail.
example.
?- example.
1, 2, 3, 4, 5, 6, 7, 8, 9, 10
true.

The code writes a comma-separated list from 1 to 10, using separate output statements for the number and the comma within a loop. The loop executes a partial body in its last iteration.


:- system:set_prolog_flag(double_quotes,codes) .

:- [library(lists)] .

%!  starts_with(FIRSTz,SECONDz)
%
% True if `SECONDz` is the beginning of `FIRSTz` .

starts_with(FIRSTz,SECONDz)
:-
lists:append(SECONDz,_,FIRSTz)
.

%!  contains(FIRSTz,SECONDz)
%
% True once if `SECONDz` is contained within `FIRSTz` at one or more positions .

contains(FIRSTz,SECONDz)
:-
contains(FIRSTz,SECONDz,_) ,
!
.

%!  contains(FIRSTz,SECONDz,NTH1)
%
% True if `SECONDz` is contained within `FIRSTz` at position `NTH1` .

contains(FIRSTz,SECONDz,NTH1)
:-
lists:append([PREFIXz,SECONDz,_SUFFIXz_],FIRSTz) ,
prolog:length(PREFIXz,NTH0) ,
NTH1 is NTH0 + 1
.

%!  ends_with(FIRSTz,SECONDz)
%
% True if `SECONDz` is the ending of `FIRSTz` .

ends_with(FIRSTz,SECONDz)
:-
lists:append(_,SECONDz,FIRSTz)
.

The code checks if a given string starts with, contains, or ends with a second string. It also prints the location of the match and handles multiple occurrences of the second string within the first string.


The code solves a puzzle where seven variables (a, b, c, d, e, f, g) are replaced with decimal digits ranging from a lower limit (LOW) to an upper limit (HIGH). The goal is to find the values of these variables such that the sum of the variables in each of the four squares is equal. The code provides all unique solutions for ranges 1-7 and 3-9, and the total number of solutions (including non-unique) for the range 0-9.


show :-
    Data = [100, 1_000, 10_000, 100_000, 1_000_000, 10_000_000, 100_000_000],
    forall(
        member(Max, Data),
        (count_triples(Max, Total, Prim),
         format("upto ~D, there are ~D Pythagorean triples (~D primitive.)~n", [Max, Total, Prim]))).

div(A, B, C) :- C is A div B.

count_triples(Max, Total, Prims) :-
    findall(S, (triple(Max, A, B, C), S is A + B + C), Ps),
    length(Ps, Prims),
    maplist(div(Max), Ps, Counts), sumlist(Counts, Total).

% - between_by/4

between_by(A, B, N, K) :-
    C is (B - A) div N,
    between(0, C, J),
    K is N*J + A.

% - Pythagorean triple generator

triple(P, A, B, C) :-
    Max is floor(sqrt(P/2)) - 1,
    between(0, Max, M),
    Start is (M /\ 1) + 1, succ(Pm, M),
    between_by(Start, Pm, 2, N),
    gcd(M, N) =:= 1,
    X is M*M - N*N,
    Y is 2*M*N,
    C is M*M + N*N,
    order2(X, Y, A, B),
    (A + B + C) =< P.

order2(A, B, A, B) :- A < B, !.
order2(A, B, B, A).

The code calculates the number of Pythagorean triples (a, b, c) where a, b, and c are positive integers, a < b < c, and a^2 + b^2 = c^2, with a perimeter (a + b + c) no larger than 100. It also determines the number of these triples that are primitive, meaning a, b, and c are co-prime. The code is also optimized to handle large values up to a maximum perimeter of 100,000,000.


?- new(D, window('Prolog Window')), send(D, open).

Creates an empty GUI window using SWI-Prolog's graphic interface XPCE, which can respond to close requests.


frequency(File) :-
	read_file_to_codes(File, Code, []),

	% we only keep alphabetic codes
	include(my_code_type, Code, LstCharCode),

	% we translate char_codes into uppercase atoms.
	maplist(my_upcase, LstCharCode, LstChar),

	% sort and pack the list
	msort(LstChar, SortLstChar),
	packList(SortLstChar, Freq),
	maplist(my_write, Freq).

my_write([Num, Atom]) :-
	swritef(A, '%3r', [Num]),
	writef('Number of %w :%w\n', [Atom, A]).

my_code_type(Code) :-
	code_type(Code, alpha).

my_upcase(CharCode, UpChar) :-
	char_code(Atom, CharCode),
	upcase_atom(Atom, UpChar).

:- use_module(library(clpfd)).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% ?- packList([a,a,a,b,c,c,c,d,d,e], L).
%  L = [[3,a],[1,b],[3,c],[2,d],[1,e]] .
%
% ?- packList(R,  [[3,a],[1,b],[3,c],[2,d],[1,e]]).
% R = [a,a,a,b,c,c,c,d,d,e] .
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
packList([],[]).

packList([X],[[1,X]]) :-
	!.

packList([X|Rest],[XRun|Packed]):-
	run(X,Rest, XRun,RRest),
	packList(RRest,Packed).

run(Var,[],[1,Var],[]).

run(Var,[Var|LRest],[N1, Var],RRest):-
	N #> 0,
	N1 #= N + 1,
	run(Var,LRest,[N, Var],RRest).

run(Var,[Other|RRest], [1,Var],[Other|RRest]):-
	dif(Var,Other).

The code opens a text file and counts the frequency of each letter, only considering alphabetic codes in uppercase. It uses the packlist/2 function for run-length encoding. It may also count all characters, including punctuation. The code is compatible with SWI-Prolog.


fractal :-
	new(D, window('Fractal')),
	send(D, size, size(800, 600)),
	drawTree(D, 400, 500, -90, 9),
	send(D, open).

drawTree(_D, _X, _Y, _Angle, 0).

drawTree(D, X1, Y1, Angle, Depth) :-
        X2 is X1 + cos(Angle * pi / 180.0) * Depth * 10.0,
        Y2 is Y1 + sin(Angle * pi / 180.0) * Depth * 10.0,
	new(Line, line(X1, Y1, X2, Y2, none)),
	send(D, display, Line),
	A1 is Angle - 30,
	A2 is Angle + 30,
	De is Depth - 1,
        drawTree(D, X2, Y2, A1, De),
        drawTree(D, X2, Y2, A2, De).

The code generates and draws a fractal tree using SWI-Prolog's graphic interface, XPCE. It begins by drawing the trunk, then splits the end of the trunk at a certain angle to create two branches. This process is repeated at the end of each branch until a desired level of branching is achieved.


brute_force_factors( N , Fs ) :-
  integer(N) ,
  N > 0 ,
  setof( F , ( between(1,N,F) , N mod F =:= 0 ) , Fs )
  .

smart_factors(N,Fs) :-
  integer(N) ,
  N > 0 ,
  setof( F , factor(N,F) , Fs )
  .

factor(N,F) :-
  L is floor(sqrt(N)) ,
  between(1,L,X) ,
  0 =:= N mod X ,
  ( F = X ; F is N // X )
  .

between(X,Y,Z) :-
  integer(X) ,
  integer(Y) ,
  X =< Z ,
  between1(X,Y,Z)
  .

between1(X,Y,X) :-
  X =< Y
  .
between1(X,Y,Z) :-
  X < Y ,
  X1 is X+1 ,
  between1(X1,Y,Z)
  .

calculate the factors of a positive integer, excluding zero and negative integers. The factors are the positive integers that can divide the given number to yield a positive integer result. For prime numbers, the factors are 1 and the number itself. The code implementation uses a simple brute force method and a slightly smarter method. Some Prolog versions may require between/3.


aligner :-
	L ="Given$a$text$file$of$many$lines,$where$fields$within$a$line$
are$delineated$by$a$single$'dollar'$character,$write$a$program
that$aligns$each$column$of$fields$by$ensuring$that$words$in$each$
column$are$separated$by$at$least$one$space.
Further,$allow$for$each$word$in$a$column$to$be$either$left$
justified,$right$justified,$or$center$justified$within$its$column.",

	% read the lines and the words
	% compute the length of the longuest word.
	% LP is the list of lines,
	% each line is a list of words
	parse(L, 0, N, LP, []),

	% we need to add 1 to aligned
	N1 is N+1,
	% words will be left aligned
	sformat(AL, '~~w~~t~~~w|', [N1]),
	% words will be centered
	sformat(AC, '~~t~~w~~t~~~w|', [N1]),
	% words will be right aligned
	sformat(AR, '~~t~~w~~~w|', [N1]),

	write('Left justified :'), nl,
	maplist(affiche(AL), LP), nl,
	write('Centered justified :'), nl,
	maplist(affiche(AC), LP), nl,
	write('Right justified :'), nl,
	maplist(affiche(AR), LP), nl.

affiche(F, L) :-
	maplist(my_format(F), L),
	nl.

my_format(_F, [13]) :-
	nl.

my_format(F, W) :-
	string_to_atom(W,AW),
	sformat(AF, F, [AW]),
	write(AF).

parse([], Max, Max) --> [].

parse(T, N, Max) -->
	{ parse_line(T, 0, N1, T1, L, []),
	  (   N1 > N -> N2 = N1; N2 = N)},
	[L],
	parse(T1, N2, Max).

parse_line([], NF, NF, []) --> [].

parse_line([H|TF], NF, NF, TF) -->
	{code_type(H, end_of_line), !},
	[].

parse_line(T, N, NF, TF) -->
	{ parse_word(T, 0, N1, T1, W, []),
	  (   N1 > N -> N2 = N1; N2 = N)},
	[W],
	parse_line(T1, N2, NF, TF).

% 36 is the code of '$'
parse_word([36|T], N, N, T) -->
	{!},
	[].

parse_word([H|T], N, N, [H|T]) -->
	{code_type(H, end_of_line), !},
	[].

parse_word([], N, N, []) --> [].

parse_word([H|T], N1, NF, TF) -->
	[H],
	{N2 is  N1 + 1},
	parse_word(T, N2, NF, TF).

The code reads a text file where each line's fields are separated by a dollar sign. It aligns each column by ensuring at least one space between words in each column. The words in a column can be left, right, or center justified. The minimum space between columns is calculated from the text, not hard-coded. The code also handles trailing dollar characters and insignificant consecutive spaces at the end of lines. The output is displayed in a mono-spaced font on a plain text editor or terminal.


cuboid(D1,D2,D3) :-
	W is D1 * 50,
	H is D2 * 50,
	D is D3 * 50,

	new(C, window(cuboid)),

	% compute the size of the window
	Width is W + ceiling(sqrt(H * 48)) + 50,
	Height is H +  ceiling(sqrt(H * 48)) + 50,
	send(C, size, new(_,size(Width,Height))),

	%compute the top-left corner of the front face of the cuboid
	PX is 25,
	PY is 25 + ceiling(sqrt(H * 48)),

	% colors of the faces
	new(C1, colour(@default, 65535, 0, 0)),
	new(C2, colour(@default, 0, 65535, 0)),
	new(C3, colour(@default, 0, 0, 65535)),

	% the front face
	new(B1, box(W, H)),
	send(B1, fill_pattern, C1),
	send(C, display,B1, point(PX, PY)),

	% the top face
	new(B2, hpara(point(PX,PY), W, D, C2)),
	send(C, display, B2),

	% the left face
	PX1 is PX + W,
	new(B3, vpara(point(PX1,PY), H, D, C3)),
	send(C, display, B3),

	send(C, open).

:- pce_begin_class(hpara, path, "drawing of a horizontal parallelogram").

initialise(P, Pos, Width, Height, Color) :->
	send(P, send_super, initialise),
	send(P, append, Pos),
	H is ceiling(sqrt(Height * 48)),
	get(Pos, x, X),
	get(Pos, y, Y),
	X1 is X + H,
	Y1 is Y - H,
	send(P, append, point(X1, Y1)),
	X2 is X1 + Width,
	send(P, append, point(X2, Y1)),
	X3 is X2 - H,
	send(P, append, point(X3, Pos?y)),
	send(P, append, Pos),
	send(P, fill_pattern, Color).

:- pce_end_class.

:- pce_begin_class(vpara, path, "drawing of a vertical parallelogram").

initialise(P, Pos, Height, Depth, Color) :->
	send(P, send_super, initialise),
	send(P, append, Pos),
	H is ceiling(sqrt(Depth * 48)),
	get(Pos, x, X),
	get(Pos, y, Y),
	X1 is X + H,
	Y1 is Y - H,
	send(P, append, point(X1, Y1)),
	Y2 is Y1 + Height,
	send(P, append, point(X1, Y2)),
	Y3 is Y2 + H,
	send(P, append, point(X, Y3)),
	send(P, append, Pos),
	send(P, fill_pattern, Color).

:- pce_end_class.

The code generates a 2x3x4 cuboid, either graphically or in ASCII art, depending on the language capabilities. It ensures three faces are visible to meet the cuboid criteria, and supports both static and rotational projection. The code is compatible with SWI-Prolog and XPCE.


:- use_module(library(ctypes)).

runtime_entry(start) :-
	prompt(_, ''),
	rot13.

rot13 :-
	get0(Ch),
	(   is_endfile(Ch) ->
		true
	;   rot13_char(Ch, Rot),
	    put(Rot),
	    rot13
	).

rot13_char(Ch, Rot) :-
	(   is_alpha(Ch) ->
		to_upper(Ch, Up),
		Letter is Up - 0'A,
		Rot is Ch + ((Letter + 13) mod 26) - Letter
	;   Rot = Ch
	).

rot13(Str, SR) :-
	maplist(rot, Str, Str1),
	string_to_list(SR, Str1).

rot(C, C1) :-
	(   member(C, "abcdefghijklmABCDEFGHIJKLM") -> C1 is C+13;
	    (	member(C, "nopqrstuvwxyzNOPQRSTUVWXYZ") -> C1 is C-13; C1 = C)).

 ?- rot13("The Quick Brown Fox Jumped Over The Lazy Dog!", SR).
SR = "Gur Dhvpx Oebja Sbk Whzcrq Bire Gur Ynml Qbt!".

The code implements a ROT-13 function that replaces each letter of the ASCII alphabet with the letter 13 characters away in the 26 letter alphabet, preserving case and passing non-alphabetic characters without alteration. This function can be optionally wrapped in a utility program similar to UNIX utility, performing line-by-line ROT-13 encoding of input from each file listed on its command line or acting as a filter on its standard input. The function is compatible with Quintus Prolog and SWI-Prolog.


example :-
    between(1,5,I), nl, between(1,I,_J),
    write('*'), fail.
example.
?- example.

*
**
***
****
*****
true.

demonstrate how to use nested 'for' loops to print a specific pattern. The number of iterations in the inner loop is controlled by the outer loop. The pattern printed consists of an increasing number of asterisks on each line. In Prolog, the 'between' function is used as an equivalent to a 'for' loop.


mymap(key1,value1).
mymap(key2,value2).

?- mymap(key1,V).
   V = value1

"Create an associative array, dictionary, map, or hash using a facts table."


Traditional[edit]
halve(X,Y) :- Y is X // 2.
double(X,Y) :- Y is 2*X.
is_even(X) :- 0 is X mod 2.

% columns(First,Second,Left,Right) is true if integers First and Second
% expand into the columns Left and Right, respectively
columns(1,Second,[1],[Second]).
columns(First,Second,[First|Left],[Second|Right]) :-
    halve(First,Halved),
    double(Second,Doubled),
    columns(Halved,Doubled,Left,Right).

% contribution(Left,Right,Amount) is true if integers Left and Right,
% from their respective columns contribute Amount to the final sum.
contribution(Left,_Right,0) :-
    is_even(Left).
contribution(Left,Right,Right) :-
    \+ is_even(Left).

ethiopian(First,Second,Product) :-
    columns(First,Second,Left,Right),
    maplist(contribution,Left,Right,Contributions),
    sumlist(Contributions,Product).

Functional Style[edit]

:- use_module(library(func)).

% halve/2, double/2, is_even/2 definitions go here

ethiopian(First,Second,Product) :-
    ethiopian(First,Second,0,Product).

ethiopian(1,Second,Sum0,Sum) :-
    Sum is Sum0 + Second.
ethiopian(First,Second,Sum0,Sum) :-
    Sum1 is Sum0 + Second*(First mod 2),
    ethiopian(halve $ First, double $ Second, Sum1, Sum).

Constraint Handling Rules[edit]

:- module(ethiopia, [test/0, mul/3]).

:- use_module(library(chr)).

:- chr_constraint mul/3, halve/2, double/2, even/1, add_odd/4.

mul(1, Y, S) <=>          S = Y.
mul(X, Y, S) <=> X \= 1 | halve(X, X1),
                          double(Y, Y1),
                          mul(X1, Y1, S1),
                          add_odd(X, Y, S1, S).

halve(X, Y) <=> Y is X // 2.

double(X, Y) <=> Y is X * 2.

even(X) <=> 0 is X mod 2 | true.
even(X) <=> 1 is X mod 2 | false.

add_odd(X, _, A, S) <=> even(X)    | S is A.
add_odd(X, Y, A, S) <=> \+ even(X) | S is A + Y.

test :-
    mul(17, 34, Z), !,
    writeln(Z).
Note that the task statement is what makes the halve and double constraints required.  Their use is highly artificial and a more realistic implementation would look like this:
:- module(ethiopia, [test/0, mul/3]).

:- use_module(library(chr)).

:- chr_constraint mul/3, even/1, add_if_odd/4.

mul(1, Y, S) <=>          S = Y.
mul(X, Y, S) <=> X \= 1 | X1 is X // 2,
                          Y1 is Y * 2,
                          mul(X1, Y1, S1),
                          add_if_odd(X, Y, S1, S).

even(X) <=> 0 is X mod 2 | true.
even(X) <=> 1 is X mod 2 | false.

add_if_odd(X, _, A, S) <=> even(X)    | S is A.
add_if_odd(X, Y, A, S) <=> \+ even(X) | S is A + Y.

test :-
    mul(17, 34, Z),
    writeln(Z).
Even this is more verbose than what a more native solution would look like.

The code defines three functions to halve an integer, double an integer, and check if an integer is even. These functions are then used to implement the Ethiopian multiplication method, which multiplies two integers using only addition, doubling, and halving operations. The multiplication process involves creating a table, discarding rows with even numbers in the left column, and summing the remaining values in the right column. The solution is implemented in Prolog language.


play24(Len, Range, Goal) :-
	game(Len, Range, Goal, L, S),
	maplist(my_write, L),
	format(': ~w~n', [S]).

game(Len, Range, Value, L, S) :-
	length(L, Len),
	maplist(choose(Range), L),
	compute(L, Value, [], S).

choose(Range, V) :-
	V is random(Range) + 1.

write_tree([M], [M]).

write_tree([+, M, N], S) :-
	write_tree(M, MS),
	write_tree(N, NS),
	append(MS, [+ | NS], S).

write_tree([-, M, N], S) :-
	write_tree(M, MS),
	write_tree(N, NS),
	(   is_add(N) -> append(MS, [-, '(' | NS], Temp), append(Temp, ')', S)
	;   append(MS, [- | NS], S)).

write_tree([Op, M, N], S) :-
	member(Op, [*, /]),
	write_tree(M, MS),
	write_tree(N, NS),
	(   is_add(M) -> append(['(' | MS], [')'], TempM)
	;  TempM = MS),
	(   is_add(N) -> append(['(' | NS], [')'], TempN)
	;   TempN = NS),
	append(TempM, [Op | TempN], S).

is_add([Op, _, _]) :-
	member(Op, [+, -]).

compute([Value], Value, [[_R-S1]], S) :-
	write_tree(S1, S2),
	with_output_to(atom(S), maplist(write, S2)).

compute(L, Value, CS, S) :-
	select(M, L, L1),
	select(N, L1, L2),
	next_value(M, N, R, CS, Expr),
	compute([R|L2], Value, Expr, S).

next_value(M, N, R, CS,[[R - [+, M1, N1]] | CS2]) :-
	R is M+N,
	(   member([M-ExprM], CS) -> select([M-ExprM], CS, CS1), M1 = ExprM
	;   M1 = [M], CS1 = CS
	),
	(   member([N-ExprN], CS1) -> select([N-ExprN], CS1, CS2), N1 = ExprN
	;   N1 = [N], CS2 = CS1
	).

next_value(M, N, R, CS,[[R - [-, M1, N1]] | CS2]) :-
	R is M-N,
	(   member([M-ExprM], CS) -> select([M-ExprM], CS, CS1), M1 = ExprM
	;   M1 = [M], CS1 = CS
	),
	(   member([N-ExprN], CS1) -> select([N-ExprN], CS1, CS2), N1 = ExprN
	;   N1 = [N], CS2 = CS1
	).

next_value(M, N, R, CS,[[R - [*, M1, N1]] | CS2]) :-
	R is M*N,
	(   member([M-ExprM], CS) -> select([M-ExprM], CS, CS1), M1 = ExprM
	;   M1 = [M], CS1 = CS
	),
	(   member([N-ExprN], CS1) -> select([N-ExprN], CS1, CS2), N1 = ExprN
	;   N1 = [N], CS2 = CS1
	).

next_value(M, N, R, CS,[[R - [/, M1, N1]] | CS2]) :-
	N \= 0,
	R is rdiv(M,N),
	(   member([M-ExprM], CS) -> select([M-ExprM], CS, CS1), M1 = ExprM
	;   M1 = [M], CS1 = CS
	),
	(   member([N-ExprN], CS1) -> select([N-ExprN], CS1, CS2), N1 = ExprN
	;   N1 = [N], CS2 = CS1
	).

my_write(V) :-
	format('~w ', [V]).

The code takes four digits as input, either from the user or randomly generated, and calculates arithmetic expressions according to the rules of the 24 game. It can also work with different goals and number ranges, not just 24 and 1-9. It uses rdiv/2 instead of //2 to solve complex cases and makes efforts to remove duplicates. Examples of solutions are also provided. Compatible with SWI-Prolog.


Works with: SWI Prolog
Recursive[edit]
fact(X, 1) :- X<2.
fact(X, F) :- Y is X-1, fact(Y,Z), F is Z*X.
Tail recursive[edit]
fact(N, NF) :-
	fact(1, N, 1, NF).

fact(X, X, F, F) :- !.
fact(X, N, FX, F) :-
	X1 is X + 1,
	FX1 is FX * X1,
	fact(X1, N, FX1, F).
Fold[edit]

% foldl(Pred, Init, List, R).
%
foldl(_Pred, Val, [], Val).
foldl(Pred, Val, [H | T], Res) :-
	call(Pred, Val, H, Val1),
	foldl(Pred, Val1, T, Res).

% factorial
p(X, Y, Z) :- Z is X * Y).

fact(X, F) :-
	numlist(2, X, L),
	foldl(p, 1, L, F).
Fold with anonymous function[edit]

:- use_module(lambda).

% foldl(Pred, Init, List, R).
%
foldl(_Pred, Val, [], Val).
foldl(Pred, Val, [H | T], Res) :-
	call(Pred, Val, H, Val1),
	foldl(Pred, Val1, T, Res).

fact(N, F) :-
	numlist(2, N, L),
	foldl(\X^Y^Z^(Z is X * Y), 1, L, F).
Continuation passing style[edit]

:- use_module(lambda).

fact(N, FN) :-
	cont_fact(N, FN, \X^Y^(Y = X)).

cont_fact(N, F, Pred) :-
	(   N = 0 ->
	    call(Pred, 1, F)
	;   N1 is N - 1,

	    P =  \Z^T^(T is Z * N),
	    cont_fact(N1, FT, P),
	    call(Pred, FT, F)
	).

The code is a function that calculates the factorial of a given number. It can be implemented iteratively or recursively. It optionally includes error handling for negative inputs. The function utilizes the Factorial Function, which multiplies a sequence of descending integers from the input number to one. The code also has a relation to Primorial numbers and uses the foldl simulation with anonymous functions from the lambda module by Ulrich Neumerkel.


:- use_module(library(lambda)).
:- use_module(library(clpfd)).

% Parameters of the server

% length of the guess
proposition(4).

% Numbers of digits
% 0 -> 8
digits(8).

bulls_and_cows_server :-
	proposition(LenGuess),
	length(Solution, LenGuess),
	choose(Solution),
	repeat,
	write('Your guess : '),
	read(Guess),
	(   study(Solution, Guess, Bulls, Cows)
	->  format('Bulls : ~w Cows : ~w~n', [Bulls, Cows]),
	    Bulls = LenGuess
	;   digits(Digits), Max is Digits + 1,
	    format('Guess must be of ~w digits between 1 and ~w~n',
		   [LenGuess, Max]),
	    fail).

choose(Solution) :-
	digits(Digits),
	Max is Digits + 1,
	repeat,
	maplist(\X^(X is random(Max) + 1), Solution),
	all_distinct(Solution),
	!.

study(Solution, Guess, Bulls, Cows) :-
	proposition(LenGuess),
	digits(Digits),

	% compute the transformation 1234 => [1,2,3,4]
	atom_chars(Guess, Chars),
	maplist(\X^Y^(atom_number(X, Y)), Chars, Ms),

	% check that the guess is well formed
	length(Ms, LenGuess),
	maplist(\X^(X > 0, X =< Digits+1), Ms),

	% compute the digit in good place
	foldl(\X^Y^V0^V1^((X = Y->V1 is V0+1; V1 = V0)),Solution, Ms, 0, Bulls),

	% compute the digits in bad place
	foldl(\Y1^V2^V3^(foldl(\X2^Z2^Z3^(X2 = Y1 -> Z3 is Z2+1; Z3 = Z2), Ms, 0, TT1),
			 V3 is V2+ TT1),
	      Solution, 0, TT),
	Cows is TT - Bulls.

The code generates a four-digit random number from 1 to 9 without duplication. It prompts the user for guesses, rejects malformed guesses, and prints the score for each guess. The score is calculated based on the number of 'bulls' and 'cows' in the guess, where a 'bull' is a digit that matches the corresponding digit in the random number and a 'cow' is a digit that exists in the random number but in a different position. The game ends when the guess matches the random number. The code is compatible with SWI-Prolog 6.1.8 and uses the lambda and clpfd modules.


dot_product(L1, L2, N) :-
	maplist(mult, L1, L2, P),
	sumlist(P, N).

mult(A,B,C) :-
	C is A*B.

 ?- dot_product([1,3,-5], [4,-2,-1], N).
N = 3.

"Implements a function to compute the dot product of two vectors of the same length by multiplying corresponding terms and summing the products."


GNU_Prolog[edit]
Works with: GNU Prolog
date_time(H).

the system time in a specified unit. This can be used for debugging, network information, random number seeds, or program performance. It may also relate to the task of date formatting and retrieving system time.


Works with: SWI-Prolog version 6

nth(N, N_Th) :-
    ( tween(N)      -> Th = "th"
    ; 1 is N mod 10 -> Th = "st"
    ; 2 is N mod 10 -> Th = "nd"
    ; 3 is N mod 10 -> Th = "rd"
    ; Th = "th" ),
    string_concat(N, Th, N_Th).

tween(N) :- Tween is N mod 100, between(11, 13, Tween).

test :-
    forall( between(0,25, N),     (nth(N, N_Th), format('~w, ', N_Th)) ),
    nl, nl,
    forall( between(250,265,N),   (nth(N, N_Th), format('~w, ', N_Th)) ),
    nl, nl,
    forall( between(1000,1025,N), (nth(N, N_Th), format('~w, ', N_Th)) ).

The code is a function that takes a non-negative integer as input and returns a string representation of the number followed by its ordinal suffix. It also demonstrates the output for the ranges 0-25, 250-265, and 1000-1025. The use of apostrophes in the output is optional.


:- use_module(library(lambda)).

stripchars(String, Exclude, Result) :-
	exclude(\X^(member(X, Exclude)), String, Result1),
	string_to_list(Result, Result1).

The code defines a function that removes a specified set of characters from a given string. The function takes two arguments: the original string and a string of characters to be removed. The function then returns the original string, stripped of any characters present in the second string. This code is compatible with SWI-Prolog and the lambda.pl module by Ulrich Neumerkel.


maxNumber(105).
factors([(3, "Fizz"), (5, "Buzz"), (7, "Baxx")]).

go :- maxNumber(M), factors(Fs), MLast is M+1, loop(1,MLast,Fs).

loop(B,B,_).
loop(A,B,Fs) :-
    A < B, fizzbuzz(A,Fs,S), ( (S = "", Res is A) ; Res = S ), writeln(Res),
    Next is A+1, loop(Next,B,Fs).

fizzbuzz(_,[],"").
fizzbuzz(N,[(F,S)|Fs],Res) :-
    fizzbuzz(N,Fs,OldRes),
    ( N mod F =:= 0, string_concat(S,OldRes,Res) ; Res = OldRes ).

?- go.

factors([(3, "Fizz"), (5, "Buzz")]).

The code is a generalized implementation of the FizzBuzz program. It accepts a maximum number and a list of factors with corresponding words from the user. It then prints numbers from 1 to the maximum number, replacing multiples of the factors with their corresponding words. If a number is a multiple of multiple factors, it prints all corresponding words in the order of least to greatest factor. The code can handle an arbitrary number of factors.


Works with: SWI-Prolog

:- op(200, xfx, user:(=+)).

%% +Prepend =+ +Chars
%
%    Will destructively update Chars
%    So that Chars = Prepend prefixed to Chars.
%    eazar001 in ##prolog helped refine this approach.

[X|Xs] =+ Chars :-
  append(Xs, Chars, Rest),
  nb_setarg(2, Chars, Rest),
  nb_setarg(1, Chars, X).

?- Str = `World!`, `Hello, ` =+ Str.
Str = "Hello, World!".

create a string variable and prepend it with another string literal. The code also includes idiomatic ways to perform this operation without referring to the variable twice. It also demonstrates the content of the variable. In Prolog, it uses the traditional representation of strings as lists of character codes and the non-logical predicate `setarg/3` to destructively set the head and tail of the list, effectively mutating the variable holding the string.


dragonCurve(N) :-
	dcg_dg(N, [left], DCL, []),
	Side = 4,
	Angle is -N * (pi/4),
	dcg_computePath(Side, Angle, DCL, point(180,400), P, []),
	new(D, window('Dragon Curve')),
	send(D, size, size(800,600)),
	new(Path, path(poly)),
	send_list(Path, append, P),
	send(D, display, Path),
	send(D, open).

% compute the list of points of the Dragon Curve
dcg_computePath(Side, Angle, [left | DCT], point(X1, Y1)) -->
	   [point(X1, Y1)],
	   {	X2 is X1 + Side * cos(Angle),
		Y2 is Y1 + Side * sin(Angle),
		Angle1 is Angle + pi / 2
	   },
	   dcg_computePath(Side, Angle1, DCT, point(X2, Y2)).

dcg_computePath(Side, Angle, [right | DCT], point(X1, Y1)) -->
	   [point(X1, Y1)],
	   {	X2 is X1 + Side * cos(Angle),
		Y2 is Y1 + Side * sin(Angle),
		Angle1 is Angle - pi / 2
	   },
	   dcg_computePath(Side, Angle1, DCT, point(X2, Y2)).

dcg_computePath(_Side, _Angle, [], point(X1, Y1)) -->
	[ point(X1, Y1)].

% compute the list of the "turns" of the Dragon Curve
dcg_dg(1, L) --> L.

dcg_dg(N, L) -->
	{dcg_dg(L, L1, []),
	  N1 is N - 1},
	  dcg_dg(N1, L1).

% one interation of the process
dcg_dg(L) -->
	L,
	[left],
	inverse(L).

inverse([H | T]) -->
	inverse(T),
	inverse(H).

inverse([]) --> [].

inverse(left) -->
	[right].

inverse(right) -->
	[left].

1 ?- dragonCurve(13).
true

The code generates a Dragon Curve fractal either for direct display or to be written to an image file. It uses recursive, successive approximation, iterative, and Lindenmayer system methods to create the fractal. The code also includes functionality to calculate absolute direction and X,Y coordinates of a point, and to test whether a given point or segment is on the curve. It is compatible with SWI-Prolog and uses DCG to compute the list of turns and points in the Dragon Curve.


Works with: SWI-Prolog version 6
main :-
    random_between(1, 10, N),
    repeat,
    prompt1('Guess the number: '),
    read(N),
    writeln('Well guessed!'),
    !.

?- main.
Guess the number: 1.
Guess the number: 2.
Guess the number: 3.
Well guessed!
true.

The code prompts the user to guess a number between 1 and 10. If the guess is incorrect, the user is prompted to guess again. The program continues to prompt the user until the correct number is guessed, at which point it displays a "Well guessed!" message and exits. A conditional loop is used to facilitate repeated guessing.


a_to_z(From, To, L) :-
	maplist(atom_codes, [From, To], [[C_From], [C_To]]),
	bagof([C], between(C_From, C_To, C), L1),
	maplist(atom_codes,L, L1).

 ?- a_to_z(a, z, L).
L = [a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z].

generate a sequence of all lower case ASCII characters from 'a' to 'z'. The sequence can be an array, list, lazy sequence, or indexable string. The code is written in a reliable style suitable for large programs and uses strong typing if available to avoid bugs. The code also demonstrates how to access a similar sequence from the standard library if it exists.


Works with: SWI Prolog
Works with: GNU Prolog
binary(X) :- format('~2r~n', [X]).
main :- maplist(binary, [5,50,9000]), halt.

generate a sequence of binary digits for a given non-negative integer. The output displays only the binary digits of each number, followed by a newline, without any whitespace, radix, sign markers, or leading zeros. The conversion can be achieved using built-in radix functions or a user-defined function.


patient(1001,'Hopper').
patient(4004,'Wirth').
patient(3003,'Kemeny').
patient(2002,'Gosling').
patient(5005,'Kurtz').

visit(2002,'2020-09-10',6.8).
visit(1001,'2020-09-17',5.5).
visit(4004,'2020-09-24',8.4).
visit(2002,'2020-10-08',nan).
visit(1001,'',6.6).
visit(3003,'2020-11-12',nan).
visit(4004,'2020-11-05',7.0).
visit(1001,'2020-11-19',5.3).

summaryDates(Id, Lastname, LastDate) :-
     aggregate(max(Ts),
	       Score^Date^(visit(Id, Date, Score), Date \= '', parse_time(Date, iso_8601, Ts)),
	       MaxTs),
     format_time(atom(LastDate), '%Y-%m-%d', MaxTs),
     patient(Id,Lastname).

summaryScores(Id, Lastname, Sum, Mean) :-
     aggregate(r(sum(Score),count), Date^(visit(Id, Date, Score), Score \= nan), r(Sum,Count)),
     patient(Id,Lastname),
     Mean is Sum/Count.

test :-
    summaryDates(Id, Lastname, LastDate),
    writeln(summaryDates(Id, Lastname, LastDate)),
    fail.

test :-
    summaryScores(Id, Lastname, ScoreSum, ScoreMean),
    writeln(summaryScores(Id, Lastname, ScoreSum, ScoreMean)),
    fail.

The code merges and aggregates two datasets from .csv files into a new dataset. It loads data from 'patients.csv' and 'visits.csv', merges them based on patient id and last name, and calculates the maximum visit date, sum, and average of scores per patient. The resulting dataset is displayed on the screen or saved to a file. The code is particularly suitable for data science and data processing languages like F#, Python, R, SPSS, MATLAB etc.


:- use_module(library( http/http_open )).

http :-
	http_open('http://www.rosettacode.org/',In, []),
	copy_stream_data(In, user_output),
	close(In).

The code accesses a specified URL's content and prints it to the console using the SWI-Prolog and http/http_open library. This is specific to HTTP requests, not HTTPS.


%repeat(Str,Num,Res).
repeat(Str,1,Str).
repeat(Str,Num,Res):-
    Num1 is Num-1,
    repeat(Str,Num1,Res1),
    string_concat(Str, Res1, Res).
alternative using DCG strings[edit]

Works with: SWI-Prolog version 7
:- system:set_prolog_flag(double_quotes,chars) .

repeat(SOURCEz0,COUNT0,TARGETz)
:-
prolog:phrase(repeat(SOURCEz0,COUNT0),TARGETz)
.

%! repeat(SOURCEz0,COUNT0)//2

repeat(_SOURCEz0_,0)
-->
! ,
[]
.

repeat(SOURCEz0,COUNT0)
-->
SOURCEz0 ,
{ COUNT is COUNT0 - 1 } ,
repeat(SOURCEz0,COUNT)
.

implement a function to repeat a given string a specified number of times. An example of this is repeating "ha" 5 times to get "hahahahaha". Additionally, the code demonstrates a more efficient way to repeat a single character, such as repeating "*" 5 times to get "*****". The implementation uses a tail-recursive DCG, which is more efficient than using lists:append.


print_expression_and_result(M, N, Operator) :-
    Expression =.. [Operator, M, N],
    Result is Expression,
    format('~w ~8|is ~d~n', [Expression, Result]).

arithmetic_integer :-
    read(M),
    read(N),
    maplist( print_expression_and_result(M, N), [+,-,*,//,rem,^] ).

?- arithmetic_integer.
|: 5.
|: 7.
5+7     is 12
5-7     is -2
5*7     is 35
5//7    is 0
5 rem 7 is 5
5^7     is 78125
true.

take two integers as input from the user and calculate their sum, difference, product, integer quotient, remainder, and exponentiation. The code does not include error handling. The integer quotient rounds towards zero and the sign of the remainder matches the sign of the first operand. The code also includes an example of the integer `divmod` operator.


Works with: SWI-Prolog version 7

count_substring(String, Sub, Total) :-
    count_substring(String, Sub, 0, Total).

count_substring(String, Sub, Count, Total) :-
    ( substring_rest(String, Sub, Rest)
    ->
        succ(Count, NextCount),
        count_substring(Rest, Sub, NextCount, Total)
    ;
        Total = Count
    ).

substring_rest(String, Sub, Rest) :-
    sub_string(String, Before, Length, Remain, Sub),
    DropN is Before + Length,
    sub_string(String, DropN, Remain, 0, Rest).

?- count_substring("the three truths","th",X).
X = 3.

?- count_substring("ababababab","abab",X).
X = 2.

version using DCG[edit]
Works with: SWI-Prolog version 7.6.4
:- system:set_prolog_flag(double_quotes,chars) .

occurrences(TARGETz0,SUBSTRINGz0,COUNT)
:-
prolog:phrase(occurrences(SUBSTRINGz0,0,COUNT),TARGETz0)
.

occurrences("",_,_)
-->
! ,
{ false }
.

occurrences(SUBSTRINGz0,COUNT0,COUNT)
-->
SUBSTRINGz0 ,
! ,
{ COUNT1 is COUNT0 + 1 } ,
occurrences(SUBSTRINGz0,COUNT1,COUNT)
.

occurrences(SUBSTRINGz0,COUNT0,COUNT)
-->
[_] ,
! ,
occurrences(SUBSTRINGz0,COUNT0,COUNT)
.

occurrences(_SUBSTRINGz0_,COUNT,COUNT)
-->
!
.

The code defines a function to count the number of non-overlapping occurrences of a given substring within a larger string. The function takes two arguments, the main string and the substring to search for, and returns an integer count. Overlapping substrings are not counted multiple times. The matching is done either from left-to-right or right-to-left to yield the maximum number of non-overlapping matches.


hanoi(N) :- move(N,left,center,right).

move(0,_,_,_) :- !.
move(N,A,B,C) :-
    M is N-1,
    move(M,A,C,B),
    inform(A,B),
    move(M,C,B,A).

inform(X,Y) :- write([move,a,disk,from,the,X,pole,to,Y,pole]), nl.

hanoi(N, Src, Aux, Dest, Moves-NMoves) :-
  NMoves is 2^N - 1,
  length(Moves, NMoves),
  phrase(move(N, Src, Aux, Dest), Moves).

move(1, Src, _, Dest) --> !,
  [Src->Dest].

move(2, Src, Aux, Dest) --> !,
  [Src->Aux,Src->Dest,Aux->Dest].

move(N, Src, Aux, Dest) -->
  { succ(N0, N) },
  move(N0, Src, Dest, Aux),
  move(1, Src, Aux, Dest),
  move(N0, Aux, Src, Dest).

"Output: The code uses recursion to solve the Towers of Hanoi problem, as per the task described in Programming in Prolog by W.F. Clocksin & C.S. Mellish. It separates core logic from IO using DCGs."


:- use_module(library(pce)).

animation :-
    new(D, window('Animation')),
    new(Label, label(hello, 'Hello world ! ')),
    send(D, display, Label, point(1,10)),
    new(@animation, animation(Label)),
    send(D, recogniser,
         new(_G, my_click_gesture(left, ''))),

    send(D, done_message, and(message(@animation, free),
                  message(@receiver, destroy))),
    send(D, open),
    send(@animation?mytimer, start).

:- pce_begin_class(animation(label), object).
variable(label, object,  both, "Display window").
variable(delta,    object, both,  "increment of the angle").
variable(mytimer, timer, both, "timer of the animation").

initialise(P, W:object) :->
        "Creation of the object"::
        send(P, label, W),
        send(P, delta, to_left),
    send(P, mytimer, new(_, timer(0.5,message(P, anim_message)))).

% method called when the object is destroyed
% first the timer is stopped
% then all the resources are freed
unlink(P) :->
    send(P?mytimer, stop),
    send(P, send_super, unlink).

% message processed by the timer
anim_message(P) :->
    get(P, label, L),
    get(L, selection, S),
    get(P, delta, Delta),
    compute(Delta, S, S1),
    new(A, name(S1)),
    send(L, selection, A).

:- pce_end_class.

:- pce_begin_class(my_click_gesture, click_gesture,
           "Click in a window").

class_variable(button, button_name, left,
           "By default click with left button").

terminate(G, Ev:event) :->
    send(G, send_super, terminate, Ev),
    get(@animation, delta, D),
    (   D = to_left -> D1 = to_right; D1 = to_left),
    send(@animation, delta, D1).

:- pce_end_class.

% compute next text to be dispalyed
compute(to_right, S, S1) :-
    get(S, size, Len),
    Len1 is Len - 1,
    get(S, sub, Len1, Str),
    get(S, delete_suffix, Str, V),
    get(Str, append, V, S1).

compute(to_left, S, S1) :-
    get(S, sub, 0, 1, Str),
    get(S, delete_prefix, Str, V),
    get(V, append, Str, S1).

create a GUI animation where a "Hello World!" string appears to rotate right by periodically moving the last letter to the front. The direction of rotation reverses when the user clicks on the text. The animation is implemented using SWI-Prolog's graphic interface XPCE.


% initial condition
do(0):- write(0),nl,do(1).

% control condition
do(V):- 0 is mod(V,6), !, fail.

% loop
do(V) :-
    write(V),nl,
    Y is V + 1,
    do(Y).

wloop :-
   do(0).

The code initializes a value to 0, then enters a do-while loop where it increments the value by 1 and prints it, continuing as long as the value modulo 6 is not 0. The loop is guaranteed to execute at least once.


remove_first_last_chars :-
    L = "Rosetta",
    L = [_|L1],
    remove_last(L, L2),
    remove_last(L1, L3),
    writef('Original string      : %s\n', [L]),
    writef('Without first char       : %s\n', [L1]),
    writef('Without last char        : %s\n', [L2]),
    writef('Without first/last chars : %s\n', [L3]).

remove_last(L, LR) :-
    append(LR, [_], L).

 ?- remove_first_last_chars.
Original string          : Rosetta
Without first char       : osetta
Without last char        : Rosett
Without first/last chars : osett
true.

demonstrate how to remove the first, last, or both the first and last characters from a string. It works with any valid Unicode code point in UTF-8 or UTF-16 encoding, referencing logical characters not code units. It is not designed to handle all Unicode characters in other encodings like 8-bit ASCII or EUC-JP.


:- use_module(library(clpfd)).

sudoku(Rows) :-
        length(Rows, 9), maplist(length_(9), Rows),
        append(Rows, Vs), Vs ins 1..9,
        maplist(all_distinct, Rows),
        transpose(Rows, Columns), maplist(all_distinct, Columns),
        Rows = [A,B,C,D,E,F,G,H,I],
        blocks(A, B, C), blocks(D, E, F), blocks(G, H, I).

length_(L, Ls) :- length(Ls, L).

blocks([], [], []).
blocks([A,B,C|Bs1], [D,E,F|Bs2], [G,H,I|Bs3]) :-
        all_distinct([A,B,C,D,E,F,G,H,I]),
        blocks(Bs1, Bs2, Bs3).

problem(1, [[_,_,_,_,_,_,_,_,_],
            [_,_,_,_,_,3,_,8,5],
            [_,_,1,_,2,_,_,_,_],
            [_,_,_,5,_,7,_,_,_],
            [_,_,4,_,_,_,1,_,_],
            [_,9,_,_,_,_,_,_,_],
            [5,_,_,_,_,_,_,7,3],
            [_,_,2,_,1,_,_,_,_],
            [_,_,_,_,4,_,_,_,9]]).

GNU Prolog version[edit]
Works with: GNU Prolog version 1.4.4
:- initialization(main).

solve(Rows) :-
    maplist(domain_1_9, Rows)
  , different(Rows)
  , transpose(Rows,Cols), different(Cols)
  , blocks(Rows,Blocks) , different(Blocks)
  , maplist(fd_labeling, Rows)
  .

domain_1_9(Rows) :- fd_domain(Rows,1,9).
different(Rows)  :- maplist(fd_all_different, Rows).

blocks(Rows,Blocks) :-
    maplist(split3,Rows,Xs), transpose(Xs,Ys)
  , concat(Ys,Zs), concat_map(split3,Zs,Blocks)
  . % where
    split3([X,Y,Z|L],[[X,Y,Z]|R]) :- split3(L,R).
    split3([],[]).

% utils/list
concat_map(F,Xs,Ys) :- call(F,Xs,Zs), maplist(concat,Zs,Ys).

concat([],[]).
concat([X|Xs],Ys) :- append(X,Zs,Ys), concat(Xs,Zs).

transpose([],[]).
transpose([[X]|Col], [[X|Row]]) :- transpose(Col,[Row]).
transpose([[X|Row]], [[X]|Col]) :- transpose([Row],Col).
transpose([[X|Row]|Xs], [[X|Col]|Ys]) :-
    maplist(bind_head, Row, Ys, YX)
  , maplist(bind_head, Col, Xs, XY)
  , transpose(XY,YX)
  . % where
    bind_head(H,[H|T],T).
    bind_head([],[],[]).

% tests
test([ [_,_,3,_,_,_,_,_,_]
     , [4,_,_,_,8,_,_,3,6]
     , [_,_,8,_,_,_,1,_,_]
     , [_,4,_,_,6,_,_,7,3]
     , [_,_,_,9,_,_,_,_,_]
     , [_,_,_,_,_,2,_,_,5]
     , [_,_,4,_,7,_,_,6,8]
     , [6,_,_,_,_,_,_,_,_]
     , [7,_,_,6,_,_,5,_,_]
     ]).

main :- test(T), solve(T), maplist(show,T), halt.
show(X) :- write(X), nl.

"Implement a Sudoku solver that takes a partially filled 9x9 grid as input and displays the solved Sudoku in a human-readable format. The solution utilizes the Algorithmics of Sudoku and is adapted for gprolog 1.3.1, running in 0.02 time and using 68352 memory."


Works with: SWI-Prolog
Library: clpfd
:- use_module(library(clpfd)).

caesar :-
	L1 = "The five boxing wizards jump quickly",
	writef("Original : %s\n", [L1]),

	% encryption of the sentence
	encoding(3, L1, L2) ,
	writef("Encoding : %s\n", [L2]),

	% deciphering on the encoded sentence
	encoding(3, L3, L2),
	writef("Decoding : %s\n", [L3]).

% encoding/decoding of a sentence
encoding(Key, L1, L2) :-
	maplist(caesar_cipher(Key), L1, L2).

caesar_cipher(_, 32, 32) :- !.

caesar_cipher(Key, V1, V2) :-
	V #= Key + V1,

	% we verify that we are in the limits of A-Z and a-z.
	((V1 #=< 0'Z #/\ V #> 0'Z) #\/ (V1 #=< 0'z #/\ V #> 0'z)
	#\/
	(V1 #< 0'A #/\ V2 #>= 0'A)#\/ (V1 #< 0'a #/\ V2 #>= 0'a)) #==> A,

	% if we are not in these limits A is 1, otherwise 0.
	V2 #= V - A * 26,

	% compute values of V1 and V2
	label([A, V1, V2]).

implement both encoding and decoding functions of a Caesar cipher. The cipher rotates the alphabet letters based on a key ranging from 1 to 25, replacing each letter with the corresponding next letter in the alphabet. The codes also handle cases of wrapping from Z to A. The codes illustrate that Caesar cipher provides minimal security as it is vulnerable to frequency analysis and brute force attacks. The codes also demonstrate that Caesar cipher is identical to Vigenère cipher with a key length of 1 and to Rot-13 with a key of 13.


calculate the least common multiple (LCM) of two integers m and n. The LCM is the smallest positive integer that has both m and n as factors. If either m or n is zero, the LCM is zero. The LCM can be calculated by iterating all the multiples of m until finding one that is also a multiple of n, or by using the formula |m x n|/gcd(m, n), where gcd is the greatest common divisor. The LCM can also be found by merging the prime decompositions of both m and n.


?- foreach(member(X, [red,green,blue,black,white]), writeln(X)).
red
green
blue
black
white
true.

iterates through each element in a collection in order and prints it, using a "for each" loop or another type of loop if "for each" is not available.


Works with: SWI Prolog
splitup(Sep,[token(B)|BL]) --> splitup(Sep,B,BL).
splitup(Sep,[A|AL],B)      --> [A], {\+ [A] = Sep }, splitup(Sep,AL,B).
splitup(Sep,[],[B|BL])     --> Sep, splitup(Sep,B,BL).
splitup(_Sep,[],[])        --> [].
start :-
    phrase(splitup(",",Tokens),"Hello,How,Are,You,Today"),
    phrase(splitup(".",Tokens),Backtogether),
    string_to_list(ABack,Backtogether),
    writeln(ABack).

"Tokenizes a given string by separating it at commas into an array, then displays each word to the user, separated by a period, using the SWI Prolog string data type and accompanying predicates."


Recursive Euclid Algorithm[edit]
gcd(X, 0, X):- !.
gcd(0, X, X):- !.
gcd(X, Y, D):- X > Y, !, Z is X mod Y, gcd(Y, Z, D).
gcd(X, Y, D):- Z is Y mod X, gcd(X, Z, D).
Repeated Subtraction[edit]
gcd(X, 0, X):- !.
gcd(0, X, X):- !.
gcd(X, Y, D):- X =< Y, !, Z is Y - X, gcd(X, Z, D).
gcd(X, Y, D):- gcd(Y, X, D).

calculate the greatest common divisor (GCD), also known as the greatest common factor (GCF) or greatest common measure, of two integers. It is related to the task of finding the least common multiple. For more information, refer to the MathWorld and Wikipedia entries on the greatest common divisor.


Works with: SWI-Prolog version 7

numeric_string(String) :-
    atom_string(Atom, String),
    atom_number(Atom, _).

test_strings(Strings) :-
    forall( member(String, Strings),
            ( ( numeric_string(String)
              ->  Result = a
              ;   Result = 'not a' ),
              format('~w is ~w number.~n', [String, Result])
            )
          ).

?- test_strings(["123", "0.123", "-123.1", "NotNum", "1."]).
123 is a number.
0.123 is a number.
-123.1 is a number.
NotNum is not a number.
1. is not a number.
true.

implement a boolean function that checks if a given string can be interpreted as a numeric value, including floating point and negative numbers, in the language's syntax for numeric literals or numbers converted from strings.


Works with: SWI Prolog
Library clpfd[edit]
Library: clpfd

:- use_module(library(clpfd)).

% tuples (name, weights, value, nb pieces).
knapsack :-
	L = [(   map, 	        9, 	150, 	1),
	     (   compass, 	13, 	35, 	1),
	     (   water, 	153, 	200, 	2),
	     (   sandwich, 	50, 	60, 	2),
	     (   glucose, 	15, 	60, 	2),
	     (   tin, 	68, 	45, 	3),
	     (   banana, 	27, 	60, 	3),
	     (   apple, 	39, 	40, 	3),
	     (   cheese, 	23, 	30, 	1),
	     (   beer, 	52, 	10, 	3),
	     (   'suntan cream', 	11, 	70, 	1),
	     (   camera, 	32, 	30, 	1),
	     (   'T-shirt', 	24, 	15, 	2),
	     (   trousers, 	48, 	10, 	2),
	     (   umbrella, 	73, 	40, 	1),
	     (   'waterproof trousers', 	42, 	70, 	1),
	     (   'waterproof overclothes', 	43, 	75, 	1),
	     (   'note-case', 	22, 	80, 	1),
	     (   sunglasses, 	7, 	20, 	1),
	     (   towel, 	18, 	12, 	2),
	     (   socks, 	4, 	50, 	1),
	     (   book, 	30, 	10, 	2)],

	% Takes is the list of the numbers of each items
	% these numbers are between 0 and the 4th value of the tuples of the items
        maplist(collect, L, Ws, Vs, Takes),
        scalar_product(Ws, Takes, #=<, 400),
        scalar_product(Vs, Takes, #=, VM),

	% to have statistics on the resolution of the problem.
	time(labeling([max(VM), down], Takes)),
        scalar_product(Ws, Takes, #=, WM),

	%% displayinf of the results.
	compute_lenword(L, 0, Len),
	sformat(A1, '~~w~~t~~~w|', [Len]),
	sformat(A2, '~~t~~w~~~w|', [4]),
	sformat(A3, '~~t~~w~~~w|', [5]),
	print_results(A1,A2,A3, L, Takes, WM, VM).

collect((_, W, V, N), W, V, Take) :-
	Take in 0..N.

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
compute_lenword([], N, N).
compute_lenword([(Name, _, _, _)|T], N, NF):-
	atom_length(Name, L),
	(   L > N -> N1 = L; N1 = N),
	compute_lenword(T, N1, NF).

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
print_results(A1,A2,A3, [], [], WM, WR) :-
	sformat(W0, '~w ', [' ']),
	sformat(W1, A1, [' ']),
	sformat(W2, A2, [WM]),
	sformat(W3, A3, [WR]),
	format('~w~w~w~w~n', [W0,W1,W2,W3]).

print_results(A1,A2,A3, [_H|T], [0|TR], WM, VM) :-
	!,
	print_results(A1,A2,A3, T, TR, WM, VM).

print_results(A1, A2, A3, [(Name, W, V, _)|T], [N|TR], WM, VM) :-
	sformat(W0, '~w ', [N]),
	sformat(W1, A1, [Name]),
	sformat(W2, A2, [W]),
	sformat(W3, A3, [V]),
	format('~w~w~w~w~n', [W0,W1,W2,W3]),
	print_results(A1, A2, A3, T, TR, WM, VM).

The code determines the optimal combination of items a tourist should carry in his knapsack, given a maximum weight limit of 4 kg. The selection is made based on the value and weight of each item, with the aim to maximize the total value without exceeding the weight limit. The code uses the clpfd and simplex libraries by Markus Triska for computation.


incr_numerical_string(S1, S2) :-
	string_to_atom(S1, A1),
	atom_number(A1, N1),
	N2 is N1+1,
	atom_number(A2, N2),
	string_to_atom(S2, A2).

"Increments a numerical string using SWI-Prolog."


%! directory_prefix(PATHs,STOP0,PREFIX)

directory_prefix([],_STOP0_,'')
:-
!
.

directory_prefix(PATHs0,STOP0,PREFIX)
:-
prolog:once(longest_prefix(PATHs0,STOP0,LONGEST_PREFIX)) ->
prolog:atom_concat(PREFIX,STOP0,LONGEST_PREFIX) ;
PREFIX=''
.

%! longest_prefix(PATHs,STOP0,PREFIX)

longest_prefix(PATHs0,STOP0,PREFIX)
:-
QUERY=(shortest_prefix(PATHs0,STOP0,SHORTEST_PREFIX)) ,
prolog:findall(SHORTEST_PREFIX,QUERY,SHORTEST_PREFIXs) ,
lists:reverse(SHORTEST_PREFIXs,LONGEST_PREFIXs) ,
lists:member(PREFIX,LONGEST_PREFIXs)
.

%! shortest_prefix(PATHs,STOP0,PREFIX)

shortest_prefix([],_STOP0_,_PREFIX_) .

shortest_prefix([PATH0|PATHs0],STOP0,PREFIX)
:-
starts_with(PATH0,PREFIX) ,
ends_with(PREFIX,STOP0) ,
shortest_prefix(PATHs0,STOP0,PREFIX)
.

%! starts_with(TARGET,START)

starts_with(TARGET,START)
:-
prolog:atom_concat(START,_,TARGET)
.

%! ends_with(TARGET,END)

ends_with(TARGET,END)
:-
prolog:atom_concat(_,END,TARGET)
.

The code finds the common directory path from a given set of directory paths using a specified directory separator character. It tests the functionality using '/' as the directory separator and three specific strings as input paths. The code ensures the returned path is a valid directory, not just the longest common string.


median(L, Z) :-
    length(L, Length),
    I is Length div 2,
    Rem is Length rem 2,
    msort(L, S),
    maplist(sumlist, [[I, Rem], [I, 1]], Mid),
    maplist(nth1, Mid, [S, S], X),
    sumlist(X, Y),
    Z is Y/2.

The code calculates the median value of a vector of floating-point numbers. It handles even number of elements by returning the average of the two middle values. The median is found using the selection algorithm for optimal time complexity. The code also includes tasks for calculating various statistical measures like mean, mode, and standard deviation. It also calculates moving (sliding window and cumulative) averages and different types of means such as arithmetic, geometric, harmonic, quadratic, and circular.


Works with: SWI Prolog version 4.8.0
Works with: Ciao Prolog version 1.21.0

fizzbuzz :-
   forall(between(1, 100, X), print_item(X)).

print_item(X) :-
   (  X mod 15 =:= 0
   -> write('FizzBuzz')
   ;  X mod 3 =:= 0
   -> write('Fizz')
   ;  X mod 5 =:= 0
   -> write('Buzz')
   ;  write(X)
   ),
   nl.

fizzbuzz(X) :- X mod 15 =:= 0, !, write('FizzBuzz').
fizzbuzz(X) :- X mod 3 =:= 0, !, write('Fizz').
fizzbuzz(X) :- X mod 5 =:= 0, !, write('Buzz').
fizzbuzz(X) :- write(X).

dofizzbuzz :-between(1, 100, X), fizzbuzz(X), nl, fail.
dofizzbuzz.

%        N  /3?  /5?  V
fizzbuzz(_, yes, yes, 'FizzBuzz').
fizzbuzz(_, yes, no,  'Fizz').
fizzbuzz(_, no,  yes, 'Buzz').
fizzbuzz(N, no,  no,  N).

% Unifies V with 'yes' if D divides evenly into N, 'no' otherwise.
divisible_by(N, D, yes) :- N mod D =:= 0.
divisible_by(N, D, no) :- N mod D =\= 0.

% Print 'Fizz', 'Buzz', 'FizzBuzz' or N as appropriate.
fizz_buzz_or_n(N) :- N > 100.
fizz_buzz_or_n(N) :- N =< 100,
   divisible_by(N, 3, Fizz),
   divisible_by(N, 5, Buzz),
   fizzbuzz(N, Fizz, Buzz, FB),
   write(FB), nl,
   M is N+1, fizz_buzz_or_n(M).

main :-
   fizz_buzz_or_n(1).

Works with: SWI Prolog version 8.2.1 Works with: Scryer Prolog version 0.7.8
% This implementation uses modern Prolog techniques
% in order to be an idiomatic solution that uses logical purity, generality and determinism wherever possible:
% - CLP(Z): constraint logic programming on integers.
% - library(reif): efficient logical predicates based on 'Indexing dif/2'.
:- module(fizz_buzz, [main/0, integer_fizzbuzz_below_100/2, integer_fizzbuzz/2]).

:- use_module(library(reif)).

% for Scryer-Prolog:
:- use_module(library(clpz)).
:- use_module(library(between)).
:- use_module(library(iso_ext)).
:- use_module(library(si)).

% for SWI-Prolog:
% :- use_module(library(clpfd)).

% Prints all solutions to `integer_fizzbuzz_below_100` each on a separate line, in order.
% Logically-impure shell, as currently there is no logically-pure way to write to a filestream.
main :-
    forall(integer_fizzbuzz_below_100(_, FizzBuzz), write_line(FizzBuzz)).

write_line(Value) :-
    write(Value),
    nl.

% Constrains FizzBuzz results to the range 1 <= X <= 100,
% and (for the 'most general query' where neither X or FizzBuzz is concrete)
% ensures results are traversed in order low -> high X.
%
% ?- integer_fizzbuzz_below_100(X, FizzBuzz) % generate all the results in order
% ?- integer_fizzbuzz_below_100(27, Result) % Find out what output `27` will produce (it's 'Fizz'.)
% ?- integer_fizzbuzz_below_100(X, 'Fizz')   % generate all the numbers which would print 'Fizz' in order (3, 6, 9, etc).
% ?- integer_fizzbuzz_below_100(X, Res), integer_si(Res) % generate all the numbers which would print themselves in order (1, 2, 4, 6, 7, 8, 11, etc).
% ?- integer_fizzbuzz_below_100(X, Res), is_of_type(integer, Res) % SWI-Prolog version doing the same.
integer_fizzbuzz_below_100(X, FizzBuzz) :-
    between(1, 100, X),
    integer_fizzbuzz(X, FizzBuzz).

% States the relationship between a number
% and its FizzBuzz representation.
%
% Because constraints are propagated lazily,
% prompting this predicate without having constrained `Num`
% to a particular integer value will give you its definition back.
% Put differently: This predicate returns the whole solution space at once,
% and external labeling techniques are required to traverse and concretize this solution space
% in an order that we like.
integer_fizzbuzz(Num, FizzBuzz) :-
    if_(Num mod 15 #= 0, FizzBuzz = 'FizzBuzz',
        if_(Num mod 5 #= 0, FizzBuzz = 'Buzz',
            if_(Num mod 3 #= 0, FizzBuzz = 'Fizz',
                Num = FizzBuzz)
           )
       ).

% Reifiable `#=`.
#=(X, Y, T) :-
    X #= X1,
    Y #= Y1,
    zcompare(C, X1, Y1),
    eq_t(C, T).

eq_t(=, true).
eq_t(<, false).
eq_t(>, false).

The code prints numbers from 1 to 100, replacing multiples of three with 'Fizz', multiples of five with 'Buzz', and multiples of both three and five with 'FizzBuzz'. It uses different Prolog techniques for looping, including higher-order predicates, failure-driven loops, and tail recursion.


:- use_module(library(pce)).

mandelbrot :-
    new(D, window('Mandelbrot Set')),
    send(D, size, size(700, 650)),
    new(Img, image(@nil, width := 700, height := 650, kind := pixmap)),

    forall(between(0,699, I),
           (   forall(between(0,649, J),
              (   get_RGB(I, J, R, G, B),
                  R1 is (R * 256) mod 65536,
                  G1 is (G * 256) mod 65536,
                  B1 is (B * 256) mod 65536,
                  send(Img, pixel(I, J, colour(@default, R1, G1, B1))))))),
    new(Bmp, bitmap(Img)),
    send(D, display, Bmp, point(0,0)),
    send(D, open).

get_RGB(X, Y, R, G, B) :-
    CX is (X - 350) / 150,
    CY is (Y - 325) / 150,
    Iter = 570,
    compute_RGB(CX, CY, 0, 0, Iter, It),
    IterF is It \/ It << 15,
    R is IterF >> 16,
    Iter1 is IterF - R << 16,
    G is Iter1 >> 8,
    B  is Iter1 - G << 8.

compute_RGB(CX, CY, ZX, ZY, Iter, IterF) :-
    ZX * ZX + ZY * ZY < 4,
    Iter > 0,
    !,
    Tmp is  ZX * ZX - ZY * ZY + CX,
    ZY1 is 2 * ZX * ZY + CY,
    Iter1 is Iter - 1,
    compute_RGB(CX, CY, Tmp, ZY1, Iter1, IterF).

compute_RGB(_CX, _CY, _ZX, _ZY, Iter, Iter).Example :

generate and draw the Mandelbrot set using various algorithms and functions, utilizing the graphic interface XPCE of SWI-Prolog.


sum([],0).
sum([H|T],X) :- sum(T,Y), X is H + Y.
product([],1).
product([H|T],X) :- product(T,Y), X is H * X.

:- sum([1,2,3,4,5,6,7,8,9],X).
X =45;
:- product([1,2,3,4,5],X).
X = 120;

add(A,B,R):-
    R is A + B.

mul(A,B,R):-
    R is A * B.

% define fold now.
fold([], Act, Init, Init).

fold(Lst, Act, Init, Res):-
    head(Lst,Hd),
    tail(Lst,Tl),
    apply(Act,[Init, Hd, Ra]),
    fold(Tl, Act, Ra, Res).

sumproduct(Lst, Sum, Prod):-
    fold(Lst,mul,1, Prod),
    fold(Lst,add,0, Sum).

?- sumproduct([1,2,3,4],Sum,Prod).
Sum = 10,
Prod = 24 .

"Calculates the sum and product of an array of integers using fold method."


Works with: SWI-Prolog
leap_year(L) :-
	partition(is_leap_year, L, LIn, LOut),
	format('leap years : ~w~n', [LIn]),
	format('not leap years : ~w~n', [LOut]).

is_leap_year(Year) :-
	R4 is Year mod 4,
	R100 is Year mod 100,
	R400 is Year mod 400,
	(   (R4 = 0, R100 \= 0); R400 = 0).

determine if a given year is a leap year in the Gregorian calendar using a built-in function.


dept(X) :- between(1, 7, X).

police(X) :- member(X, [2, 4, 6]).
fire(X)   :- dept(X).
san(X)    :- dept(X).

assign(A, B, C) :-
    police(A), fire(B), san(C),
    A =\= B, A =\= C, B =\= C,
    12 is A + B + C.

main :-
    write("P F S"), nl,
    forall(assign(Police, Fire, Sanitation), format("~w ~w ~w~n", [Police, Fire, Sanitation])),
    halt.

?- main.

all possible combinations of unique numbers between 1 and 7 (inclusive) for three different departments (police, sanitation, fire) that add up to 12, with the police department number being an even number.


?- A = "A test string", A = B.
A = B, B = "A test string".

distinguish between copying a string's content and creating an additional reference to an existing string in Prolog, considering that values in Prolog are immutable and a variable can't be reassigned once it has been unified with a string value.


implement two mutually recursive functions to compute the Hofstadter Female and Male sequences. The functions handle cases where a language does not support mutual recursion by stating this limitation.


Works with: SWI-Prolog version 6
?- random_member(M, [a, b, c, d, e, f, g, h, i, j]).
M = i.

demonstrate how to select a random element from a list.