# Author: D. Cudnohufsky
function Get-VigenereCipher
{
    Param
    (
        [Parameter(Mandatory=$true)]
        [string] $Text,

        [Parameter(Mandatory=$true)]
        [string] $Key,

        [switch] $Decode
    )

    begin
    {
        $map = [char]'A'..[char]'Z'
    }

    process
    {
        $Key = $Key -replace '[^a-zA-Z]',''
        $Text = $Text -replace '[^a-zA-Z]',''

        $keyChars = $Key.toUpper().ToCharArray()
        $Chars = $Text.toUpper().ToCharArray()

        function encode
        {

            param
            (
                $Char,
                $keyChar,
                $Alpha = [char]'A'..[char]'Z'
            )

            $charIndex = $Alpha.IndexOf([int]$Char)
            $keyIndex = $Alpha.IndexOf([int]$keyChar)
            $NewIndex = ($charIndex + $KeyIndex) - $Alpha.Length
            $Alpha[$NewIndex]

        }

        function decode
        {

            param
            (
                $Char,
                $keyChar,
                $Alpha = [char]'A'..[char]'Z'
            )

            $charIndex = $Alpha.IndexOf([int]$Char)
            $keyIndex = $Alpha.IndexOf([int]$keyChar)
            $int = $charIndex - $keyIndex
            if ($int -lt 0) { $NewIndex = $int + $Alpha.Length }
            else { $NewIndex = $int }
            $Alpha[$NewIndex]
        }

        while ( $keyChars.Length -lt $Chars.Length )
        {
            $keyChars = $keyChars + $keyChars
        }

        for ( $i = 0; $i -lt $Chars.Length; $i++ )
        {

            if ( [int]$Chars[$i] -in $map -and [int]$keyChars[$i] -in $map )
            {
                if ($Decode) {$Chars[$i] = decode $Chars[$i] $keyChars[$i] $map}
                else {$Chars[$i] = encode $Chars[$i] $keyChars[$i] $map}

                $Chars[$i] = [char]$Chars[$i]
                [string]$OutText += $Chars[$i]
            }

        }

        $OutText
        $OutText = $null
    }
}

Encode:
PS C:\> Get-VigenereCipher 'We attack at dawn.' 'lemon'
HIMHGLGWOGOEIB

Decode:
PS C:\> Get-VigenereCipher 'HIMHGLGWOGOEIB' 'lemon' -Decode
WEATTACKATDAWN

Implement and decrypt a Vigenère cipher. The code handles keys and text of unequal length, capitalizes all characters, and discards non-alphabetic characters. If non-alphabetic characters are handled differently, a note is made.


demonstrate a for-loop with a step-value greater than one.


function  order($as,$bs) {
    if($as -and $bs) {
        $a, $as = $as
        $b, $bs = $bs
        if($a -eq $b) {order $as $bs}
        else{$a -lt $b}
    } elseif ($bs) {$true} else {$false}
}
"$(order @(1,2,1,3,2) @(1,2,0,4,4,0,0,0))"

False

function Test-Order ([int[]]$ReferenceArray, [int[]]$DifferenceArray)
{
    for ($i = 0; $i -lt $ReferenceArray.Count; $i++)
    {
        if ($ReferenceArray[$i] -lt $DifferenceArray[$i])
        {
            return $true
        }
        elseif ($ReferenceArray[$i] -gt $DifferenceArray[$i])
        {
            return $false
        }
    }

    return ($ReferenceArray.Count -lt $DifferenceArray.Count) -or (Compare-Object $ReferenceArray $DifferenceArray) -eq $null
}

Test-Order -ReferenceArray 1, 2, 1, 3, 2 -DifferenceArray 1, 2, 0, 4, 4, 0, 0, 0
Test-Order -ReferenceArray 1, 2, 1, 3, 2 -DifferenceArray 1, 2, 2, 4, 4, 0, 0, 0
Test-Order -ReferenceArray 1, 2, 3       -DifferenceArray 1, 2
Test-Order -ReferenceArray 1, 2          -DifferenceArray 1, 2, 3
Test-Order -ReferenceArray 1, 2          -DifferenceArray 1, 2

"Function to compare two numerical lists in lexicographic order and return true if the first list should be ordered before the second, false otherwise."


function ackermann ([long] $m, [long] $n) {
    if ($m -eq 0) {
        return $n + 1
    }

    if ($n -eq 0) {
        return (ackermann ($m - 1) 1)
    }

    return (ackermann ($m - 1) (ackermann $m ($n - 1)))
}

foreach ($m in 0..3) {
    foreach ($n in 0..6) {
        Write-Host -NoNewline ("{0,5}" -f (ackermann $m $n))
    }
    Write-Host
}

The code implements the Ackermann function, a non-primitive recursive function. It takes two non-negative arguments and returns their Ackermann value. The function grows quickly in value and its call tree size. It also includes a feature to save the result to an array for future use and display it using the Format-Wide cmdlet. The code handles arbitrary precision but it's not mandatory.


Add-Type -Path "C:\Program Files (x86)\Math\MathNet.Numerics.3.12.0\lib\net40\MathNet.Numerics.dll"

1..20 | ForEach-Object {[MathNet.Numerics.SpecialFunctions]::Gamma($_ / 10)}

The code implements an algorithm to compute the Gamma function in the real field. It compares the results of this implementation with built-in/library functions. The Gamma function is computed using numerical integration, Lanczos approximation, and Stirling's approximation. The code also involves the use of Math.NET Numerics dll(s).


Works with: PowerShell version 2
function PlaceQueen ( [ref]$Board, $Row, $N )
    {
    #  For the current row, start with the first column
    $Board.Value[$Row] = 0

    #  While haven't exhausted all columns in the current row...
    While ( $Board.Value[$Row] -lt $N )
        {
        #  If not the first row, check for conflicts
        $Conflict = $Row -and
                    (   (0..($Row-1)).Where{ $Board.Value[$_] -eq $Board.Value[$Row] }.Count -or
                        (0..($Row-1)).Where{ $Board.Value[$_] -eq $Board.Value[$Row] - $Row + $_ }.Count -or
                        (0..($Row-1)).Where{ $Board.Value[$_] -eq $Board.Value[$Row] + $Row - $_ }.Count )

        #  If no conflicts and the current column is a valid column...
        If ( -not $Conflict -and $Board.Value[$Row] -lt $N )
            {

            #  If this is the last row
            #    Board completed successfully
            If ( $Row -eq ( $N - 1 ) )
                {
                return $True
                }

            #  Recurse
            #  If all nested recursions were successful
            #    Board completed successfully
            If ( PlaceQueen $Board ( $Row + 1 ) $N )
                {
                return $True
                }
            }

        #  Try the next column
        $Board.Value[$Row]++
        }

    #  Everything was tried, nothing worked
    Return $False
    }

function Get-NQueensBoard ( $N )
    {
    #  Start with a default board (array of column positions for each row)
    $Board = @( 0 ) * $N

    #  Place queens on board
    #  If successful...
    If ( PlaceQueen -Board ([ref]$Board) -Row 0 -N $N )
        {
        #  Convert board to strings for display
        $Board | ForEach { ( @( "" ) + @(" ") * $_ + "Q" + @(" ") * ( $N - $_ ) ) -join "|" }
        }
    Else
        {
        "There is no solution for N = $N"
        }
    }

Get-NQueensBoard 8
''
Get-NQueensBoard 3
''
Get-NQueensBoard 4
''
Get-NQueensBoard 14

"Solve the N-queens problem for an NxN board and provide the number of solutions for small values of N."


demonstrate how to concatenate two arrays.


using namespace System.Collections.Generic
$ErrorActionPreference = 'Stop'
class Person{
    #private
    hidden [int] $_candidateIndex;
    [string] $Name
    #[System.Collections.Generic.List[Person]] $Prefs
    [List[Person]] $Prefs
    [Person] $Fiance

    Person([string] $name) {
            $this.Name = $name;
            $this.Prefs = $null;
            $this.Fiance = $null;
            $this._candidateIndex = 0;
        }
    [bool] Prefers([Person] $p) {
            return $this.Prefs.FindIndex({ param($o) $o -eq $p }) -lt $this.Prefs.FindIndex({ param($o) $o -eq $this.Fiance });
        }

    [Person] NextCandidateNotYetProposedTo() {
            if ($this._candidateIndex -ge $this.Prefs.Count) {return $null;}
            return $this.Prefs[$this._candidateIndex++];
        }

    [void] EngageTo([Person] $p) {
            if ($p.Fiance -ne $null) {$p.Fiance.Fiance = $null};
            $p.Fiance = $this;
            if ($this.Fiance -ne $null){$this.Fiance.Fiance = $null};
            $this.Fiance = $p;
        }

    }

    class MainClass
    {
        static  [bool] IsStable([List[Person]] $men) {
            [List[Person]] $women = $men[0].Prefs;
            foreach ($guy in $men){
                foreach ($gal in $women) {
                    if ($guy.Prefers($gal) -and $gal.Prefers($guy))
                        {return $false};
                }
            }
            return $true;
        }

        static [void] DoMarriage() {
            [Person] $abe  = [Person]::new("abe");
            [Person] $bob  = [Person]::new("bob");
            [Person] $col  = [Person]::new("col");
            [Person] $dan  = [Person]::new("dan");
            [Person] $ed   = [Person]::new("ed");
            [Person] $fred = [Person]::new("fred");
            [Person] $gav  = [Person]::new("gav");
            [Person] $hal  = [Person]::new("hal");
            [Person] $ian  = [Person]::new("ian");
            [Person] $jon  = [Person]::new("jon");
            [Person] $abi  = [Person]::new("abi");
            [Person] $bea  = [Person]::new("bea");
            [Person] $cath = [Person]::new("cath");
            [Person] $dee  = [Person]::new("dee");
            [Person] $eve  = [Person]::new("eve");
            [Person] $fay  = [Person]::new("fay");
            [Person] $gay  = [Person]::new("gay");
            [Person] $hope = [Person]::new("hope");
            [Person] $ivy  = [Person]::new("ivy");
            [Person] $jan  = [Person]::new("jan");

            $abe.Prefs =[Person[]]@($abi, $eve, $cath, $ivy, $jan, $dee, $fay, $bea, $hope, $gay)
            $bob.Prefs  = [Person[]] @($cath, $hope, $abi, $dee, $eve, $fay, $bea, $jan, $ivy, $gay);
            $col.Prefs  = [Person[]] @($hope, $eve, $abi, $dee, $bea, $fay, $ivy, $gay, $cath, $jan);
            $dan.Prefs  = [Person[]] @($ivy, $fay, $dee, $gay, $hope, $eve, $jan, $bea, $cath, $abi);
            $ed.Prefs   = [Person[]] @($jan, $dee, $bea, $cath, $fay, $eve, $abi, $ivy, $hope, $gay);
            $fred.Prefs = [Person[]] @($bea, $abi, $dee, $gay, $eve, $ivy, $cath, $jan, $hope, $fay);
            $gav.Prefs  = [Person[]] @($gay, $eve, $ivy, $bea, $cath, $abi, $dee, $hope, $jan, $fay);
            $hal.Prefs  = [Person[]] @($abi, $eve, $hope, $fay, $ivy, $cath, $jan, $bea, $gay, $dee);
            $ian.Prefs  = [Person[]] @($hope, $cath, $dee, $gay, $bea, $abi, $fay, $ivy, $jan, $eve);
            $jon.Prefs  = [Person[]] @($abi, $fay, $jan, $gay, $eve, $bea, $dee, $cath, $ivy, $hope);
            $abi.Prefs  = [Person[]] @($bob, $fred, $jon, $gav, $ian, $abe, $dan, $ed, $col, $hal);
            $bea.Prefs  = [Person[]] @($bob, $abe, $col, $fred, $gav, $dan, $ian, $ed, $jon, $hal);
            $cath.Prefs = [Person[]] @($fred, $bob, $ed, $gav, $hal, $col, $ian, $abe, $dan, $jon);
            $dee.Prefs  = [Person[]] @($fred, $jon, $col, $abe, $ian, $hal, $gav, $dan, $bob, $ed);
            $eve.Prefs  = [Person[]] @($jon, $hal, $fred, $dan, $abe, $gav, $col, $ed, $ian, $bob);
            $fay.Prefs  = [Person[]] @($bob, $abe, $ed, $ian, $jon, $dan, $fred, $gav, $col, $hal);
            $gay.Prefs  = [Person[]] @($jon, $gav, $hal, $fred, $bob, $abe, $col, $ed, $dan, $ian);
            $hope.Prefs = [Person[]] @($gav, $jon, $bob, $abe, $ian, $dan, $hal, $ed, $col, $fred);
            $ivy.Prefs  = [Person[]] @($ian, $col, $hal, $gav, $fred, $bob, $abe, $ed, $jon, $dan);
            $jan.Prefs  = [Person[]] @($ed, $hal, $gav, $abe, $bob, $jon, $col, $ian, $fred, $dan);

            [List[Person]] $men = [List[Person]]::new($abi.Prefs);

            [int] $freeMenCount = $men.Count;
            while ($freeMenCount -gt 0) {
                foreach ($guy in $men) {
                    if ($guy.Fiance -eq $null) {
                        [Person]$gal = $guy.NextCandidateNotYetProposedTo();
                        if ($gal.Fiance -eq $null) {
                            $guy.EngageTo($gal);
                            $freeMenCount--;
                        }
                        else{
                            if ($gal.Prefers($guy)) {
                                $guy.EngageTo($gal);
                            }
                        }

                    }
                }
            }

            foreach ($guy in $men) {
                write-host $guy.Name " is engaged to " $guy.Fiance.Name

            }
            write-host "Stable = " ([MainClass]::IsStable($men))

            write-host "Switching fred & jon's partners";
            [Person] $jonsFiance = $jon.Fiance;
            [Person] $fredsFiance = $fred.Fiance;
            $fred.EngageTo($jonsFiance);
            $jon.EngageTo($fredsFiance);
            write-host "Stable = " ([MainClass]::IsStable($men));

        }
     static [void] Main([string[]] $args)
        {
            [MainClass]::DoMarriage();
        }

    }

[MainClass]::DoMarriage()

The code implements the Gale-Shapley algorithm to solve the Stable Marriage Problem. It takes as input the preferences of ten males and ten females for potential partners. The algorithm generates a stable set of engagements where no individual prefers someone else over their current partner, who also prefers them over their current partner. The code also perturbs this stable set to create an unstable set and checks its stability.


#  Simulated fast function
function a ( [boolean]$J ) { return $J }

#  Simulated slow function
function b ( [boolean]$J ) { Sleep -Seconds 2; return $J }

#  These all short-circuit and do not evaluate the right hand function
( a $True  ) -or  ( b $False )
( a $True  ) -or  ( b $True  )
( a $False ) -and ( b $False )
( a $False ) -and ( b $True  )

#  Measure of execution time
Measure-Command {
( a $True  ) -or  ( b $False )
( a $True  ) -or  ( b $True  )
( a $False ) -and ( b $False )
( a $False ) -and ( b $True  )
} | Select TotalMilliseconds

#  These all appropriately do evaluate the right hand function
( a $False ) -or  ( b $False )
( a $False ) -or  ( b $True  )
( a $True  ) -and ( b $False )
( a $True  ) -and ( b $True  )

#  Measure of execution time
Measure-Command {
( a $False ) -or  ( b $False )
( a $False ) -or  ( b $True  )
( a $True  ) -and ( b $False )
( a $True  ) -and ( b $True  )
} | Select TotalMilliseconds

The code defines two functions, 'a' and 'b', both of which take a boolean value as input, return the same value, and print their name when called. The code then calculates the values of two boolean expressions 'x' and 'y' using these functions. The calculation is done in such a way that function 'b' is only called when necessary, utilizing the concept of short-circuit evaluation. If the language does not support short-circuit evaluation, nested 'if' statements are used instead. PowerShell natively supports this feature.


function Send-MorseCode
{
    [CmdletBinding()]
    [OutputType([string])]
    Param
    (
        [Parameter(Mandatory=$true,
                   ValueFromPipeline=$true,
                   Position=0)]
        [string]
        $Message,

        [switch]
        $ShowCode
    )

    Begin
    {
        $morseCode = @{
            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 = "----."
        }
    }
    Process
    {
        foreach ($word in $Message)
        {
            $word.Split(" ",[StringSplitOptions]::RemoveEmptyEntries) | ForEach-Object {

                foreach ($char in $_.ToCharArray())
                {
                    if ($char -in $morseCode.Keys)
                    {
                        foreach ($code in ($morseCode."$char").ToCharArray())
                        {
                            if ($code -eq ".") {$duration = 250} else {$duration = 750}

                            [System.Console]::Beep(1000, $duration)
                            Start-Sleep -Milliseconds 50
                        }

                        if ($ShowCode) {Write-Host ("{0,-6}" -f ("{0,6}" -f $morseCode."$char")) -NoNewLine}
                    }
                }

                if ($ShowCode) {Write-Host}
            }

            if ($ShowCode) {Write-Host}
        }
    }
}

Send-MorseCode -Message "S.O.S" -ShowCode

"Function to convert a given string into Morse code and play it as audible sound through an audio device. It handles unknown characters by either ignoring them or indicating them with a different pitch. The function is case insensitive and can optionally display the Morse code."


<#
.Synopsis
  ABC Problem
.DESCRIPTION
   You are given a collection of ABC blocks. Just like the ones you had when you were a kid.
   There are twenty blocks with two letters on each block. You are guaranteed to have a
   complete alphabet amongst all sides of the blocks
   blocks = "BO","XK","DQ","CP","NA","GT","RE","TG","QD","FS","JW","HU","VI","AN","OB","ER","FS","LY","PC","ZM"
   The goal of this task is to write a function that takes a string and can determine whether
   you can spell the word with the given collection of blocks.

   The rules are simple:
        1.Once a letter on a block is used that block cannot be used again
        2.The function should be case-insensitive
        3. Show your output on this page for the following words:
        >>> can_make_word("A")
        True
        >>> can_make_word("BARK")
        True
        >>> can_make_word("BOOK")
        False
        >>> can_make_word("TREAT")
        True
        >>> can_make_word("COMMON")
        False
        >>> can_make_word("SQUAD")
        True
        >>> can_make_word("CONFUSE")
        True

   Using the examples below  you can either see just the value or
   status and the values using the verbose switch

.EXAMPLE
   test-blocks -testword confuse

.EXAMPLE
   test-blocks -testword confuse -verbose

#>

function test-blocks
{
	[CmdletBinding()]
	#  [OutputType([int])]
	Param
	(
		# word to test against blocks
		[Parameter(Mandatory = $true,
				   ValueFromPipelineByPropertyName = $true)]
		$testword

	)

	$word = $testword

	#define array of blocks
	[System.Collections.ArrayList]$blockarray = "BO", "XK", "DQ", "CP", "NA", "GT", "RE", "TG", "QD", "FS", "JW", "HU", "VI", "AN", "OB", "ER", "FS", "LY", "PC", "ZM"

	#send word to chararray
	$chararray = $word.ToCharArray()
	$chars = $chararray

	#get the character count
	$charscount = $chars.count

	#get the initial count of the blocks
	$blockcount = $blockarray.Count

	#find out how many blocks should be left from the difference
	#of the blocks and characters in the word - 1 letter/1 block
	$correctblockcount = $blockcount - $charscount

	#loop through the characters in the word
	foreach ($char in $chars)
	{

		#loop through the blocks
		foreach ($block in $blockarray)
		{

			#check the current character against each letter on the current block
			#and break if found so the array can reload
			if ($char -in $block[0] -or $char -in $block[1])
			{

				write-verbose "match for letter - $char - removing block $block"
				$blockarray.Remove($block)
				break

			}

		}

	}
	#get final count of blocks left in array to determine if the word was
	#correctly made
	$finalblockcount = $blockarray.count
	if ($finalblockcount -ne $correctblockcount)
	{
		write-verbose "$word : $false "
		return $false
	}
	else
	{
		write-verbose "$word : $true "
		return $true
	}

}

#loop all the words and pass them to the function
$wordlist = "a", "bark", "book", "treat", "common", "squad", "confuse"
foreach ($word in $wordlist)
{
	test-blocks -testword $word -Verbose
}

"Output: The code defines a function that checks 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 and returns a boolean value based on whether or not the word can be formed."


$string = "The quick brown fox jumped over the lazy dog's back"
$data = [Text.Encoding]::UTF8.GetBytes($string)
$hash = [Security.Cryptography.MD5]::Create().ComputeHash($data)
([BitConverter]::ToString($hash) -replace '-').ToLower()

implement an MD5 encoding for a given string. The codes also include an optional validation using test values from IETF RFC (1321) for MD5. However, due to known weaknesses of MD5, alternatives like SHA-256 or SHA-3 are recommended for production-grade cryptography. If the solution is a library, refer to MD5/Implementation for a scratch implementation.


[hashtable]$mailMessage = @{
    From = "weirdBoy@gmail.com"
    To = "anudderBoy@YourDomain.com"
    Cc = "daWaghBoss@YourDomain.com"
    Attachment = "C:\temp\Waggghhhh!_plan.txt"
    Subject = "Waggghhhh!"
    Body = "Wagggghhhhhh!"
    SMTPServer = "smtp.gmail.com"
    SMTPPort = "587"
    UseSsl = $true
    ErrorAction = "SilentlyContinue"
}

Send-MailMessage @mailMessage

implement a function to send an email using PowerShell's 'Send-MailMessage' cmdlet. The function includes parameters for setting 'From', 'To', 'Cc' addresses, 'Subject', and 'message text'. Optional fields for server name and login details are also included. The solution is portable across different operating systems.


[int64]$i = 0
While ( $True )
    {
    [Convert]::ToString( ++$i, 8 )
    }

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.


$b, $a = $a, $b

function swap ([ref] $a, [ref] $b) {
    $a.Value, $b.Value = $b.Value, $a.Value
}

swap ([ref] $a) ([ref] $b)

define a generic swap function or operator that can interchange the values of two variables or storage places, regardless of their types. This function should work in both statically and dynamically typed languages, with certain constraints for type compatibility. In functional languages, the function may not allow destructive operations. The function should also handle issues related to parametric polymorphism in static languages. In PowerShell, the function can use tuple assignment for swapping.


Function Test-Palindrome( [String] $Text ){
    $CharArray = $Text.ToCharArray()
    [Array]::Reverse($CharArray)
    $Text -eq [string]::join('', $CharArray)
}

function Test-Palindrome
{
  <#
    .SYNOPSIS
        Tests if a string is a palindrome.
    .DESCRIPTION
        Tests if a string is a true palindrome or, optionally, an inexact palindrome.
    .EXAMPLE
        Test-Palindrome -Text "racecar"
    .EXAMPLE
        Test-Palindrome -Text '"Deliver desserts," demanded Nemesis, "emended, named, stressed, reviled."' -Inexact
  #>
    [CmdletBinding()]
    [OutputType([bool])]
    Param
    (
        # The string to test for palindrominity.
        [Parameter(Mandatory=$true)]
        [string]
        $Text,

        # When specified, detects an inexact palindrome.
        [switch]
        $Inexact
    )

    if ($Inexact)
    {
        # Strip all punctuation and spaces
        $Text = [Regex]::Replace("$Text($7&","[^1-9a-zA-Z]","")
    }

    $Text -match "^(?'char'[a-z])+[a-z]?(?:\k'char'(?'-char'))+(?(char)(?!))$"
}
Test-Palindrome -Text 'radar'

The code defines a function to check if a given sequence of characters is a palindrome. It supports Unicode characters and also includes a second function to detect inexact palindromes, ignoring white-space, punctuation, and case. The code uses string reversal and Unicode categories for character identification.


demonstrate how to access a process's environment variables such as PATH, HOME, and USER, which are commonly found on Unix systems. The environment variables are located in the Env: drive and can be retrieved using a specific variable syntax. The code also includes a feature to list all environment variables by querying the drive's contents.


type Stack a = [a]

create :: Stack a
create = []

push :: a -> Stack a -> Stack a
push = (:)

pop :: Stack a -> (a, Stack a)
pop []     = error "Stack empty"
pop (x:xs) = (x,xs)

empty :: Stack a -> Bool
empty = null

peek :: Stack a -> a
peek []    = error "Stack empty"
peek (x:_) = x

import Control.Monad.State

type Stack a b = State [a] b

push :: a -> Stack a ()
push = modify . (:)

pop :: Stack a a
pop = do
    nonEmpty
    x <- peek
    modify tail
    return x

empty :: Stack a Bool
empty = gets null

peek :: Stack a a
peek = nonEmpty >> gets head

nonEmpty :: Stack a ()
nonEmpty = empty >>= flip when (fail "Stack empty")

implement a stack data structure with basic operations such as push, pop, and empty. The stack follows a last in, first out (LIFO) access policy and is accessed through its top. The 'push' operation stores a new element onto the stack top, 'pop' returns and removes the last pushed stack element, and 'empty' checks if the stack contains no elements. The topmost element can be accessed for read or write without modifying the stack. The implementation also supports a purely functional approach where pop returns both the element and the changed stack.


The code defines a function to generate the nth Fibonacci number, either iteratively or recursively. It optionally supports negative numbers using an inverse definition. The function can also use Binet's formula and an exact real arithmetic library for precise calculations, even for large numbers. It includes an optimized version using a memoizer for faster execution. The code also demonstrates the use of lazy lists to generate an infinite list of all Fibonacci numbers. It includes a version that supports negative numbers and uses accumulator to hold the last two members of the series. The code also uses Fibonacci recurrence identities for efficient calculation of large Fibonacci numbers.


ary = [1..10]
evens = [x | x <- ary, even x]

evens = filter even ary

import Data.Array

ary = listArray (1,10) [1..10]
evens = listArray (1,n) l where
  n = length l
  l = [x | x <- elems ary, even x]

select specific elements from an array, in this case, even numbers, and place them into a new array. Alternatively, the code can modify the original array directly. In Haskell, this operation is typically done on a list, but it can also be done on an array by converting it into a list. The bounds of the array must be known before its creation.


Works with: Haskell version 6.10.4

The first three tasks are simply:
*Main> take 3 $ drop 2 "1234567890"
"345"

*Main> drop 2 "1234567890"
"34567890"

*Main> init "1234567890"
"123456789"

The last two can be formulated with the following function:
t45 n c s | null sub = []
          | otherwise = take n. head $ sub
  where sub = filter(isPrefixOf c) $ tails s

*Main> t45 3 "4" "1234567890"
"456"

*Main> t45 3 "45" "1234567890"
"456"

*Main> t45 3 "31" "1234567890"
""

Works with: Haskell version 8.0.2
{-# LANGUAGE OverloadedStrings #-}

import qualified Data.Text as T (Text, take, drop, init, breakOn)
import qualified Data.Text.IO as O (putStrLn)

fromMforN :: Int -> Int -> T.Text -> T.Text
fromMforN n m s = T.take m (T.drop n s)

fromNtoEnd :: Int -> T.Text -> T.Text
fromNtoEnd = T.drop

allButLast :: T.Text -> T.Text
allButLast = T.init

fromCharForN, fromStringForN :: Int -> T.Text -> T.Text -> T.Text
fromCharForN m needle haystack = T.take m $ snd $ T.breakOn needle haystack

fromStringForN = fromCharForN

-- TEST ---------------------------------------------------
main :: IO ()
main =
  mapM_
    O.putStrLn
    ([ fromMforN 9 10
     , fromNtoEnd 20
     , allButLast
     , fromCharForN 6 "话"
     , fromStringForN 6 "大势"
     ] <*>
     ["天地不仁仁者人也🐒话说天下大势分久必合🍑合久必分🔥"])

The code performs the following tasks:
1. Displays a substring starting from 'n' characters in and of 'm' length.
2. Displays a substring starting from 'n' characters in, up to the end of the string.
3. Displays the whole string minus the last character.
4. Displays a substring starting from a known character within the string and of 'm' length.
5. Displays a substring starting from a known substring within the string and of 'm' length.
The code is compatible with any valid Unicode code point, including UTF-8 or UTF-16, and references logical characters, not 8-bit code units for UTF-8 or 16-bit code units for UTF-16. It is not required to handle all Unicode characters for other encodings like 8-bit ASCII, or EUC-JP. In Haskell, the string is represented as a list of chars: [Char]. The code also includes tests with an extended set of characters using Data.Text functions, including breakOn.


reverse = foldl (flip (:)) []

accumulatingReverse :: [a] -> [a]
accumulatingReverse lst =
  let rev xs a = foldl (flip (:)) a xs
  in rev lst []

import Data.Char (isMark)
import Data.List (groupBy)
myReverse = concat . reverse . groupBy (const isMark)

"Function to reverse a string while preserving Unicode combining characters. For instance, it transforms 'asdf' into 'fdsa' and 'as⃝df̅' into 'f̅ds⃝a'. The function is optimized using a helper function with an accumulator argument, and it uses 'groupBy (const isMark)' for splitting a string into its combined characters."


This example is incorrect.  Please fix the code and remove this message.Details: TREESTUMP -> TREXSTUMPX, should be TREXESTUMP

import Control.Monad     (guard)
import Data.Array        (Array, assocs, elems, listArray, (!))
import Data.Char         (toUpper)
import Data.List         (nub, (\\))
import Data.List.Split   (chunksOf)
import Data.Maybe        (listToMaybe)
import Data.String.Utils (replace)

type Square a = Array (Int, Int) a

-- | Turns a list into an n*m-array.
array2D ::
       (Int, Int) -- ^ n * m
    -> [e] -> Square e
array2D maxCoord = listArray ((1, 1), maxCoord)

-- | Generates a playfair table starting with the specified string.
--
-- >>> makeTable "hello"
-- "HELOABCDFGIKMNPQRSTUVWXYZ"
makeTable :: String -> String
makeTable k = nub key ++ (alpha \\ key)
    where
      alpha = ['A' .. 'Z'] \\ "J"
      key = map toUpper =<< words k

-- | Turns a playfair table into a 5*5 alphabet square.
makeSquare :: [a] -> Square a
makeSquare = array2D (5, 5)

-- | Displays a playfair square, formatted as a square.
showSquare :: Square Char -> String
showSquare d = unlines $ chunksOf 5 (elems d)

-- | Given a value and an association list of x-coordinate * y-coordinate * value, returns the coordinates
getIndex' :: (Eq a) => a -> [((Int, Int), a)] -> Maybe (Int, Int)
getIndex' el = fmap fst . listToMaybe . filter ((== el) . snd)

encodePair, decodePair :: Eq a => Square a -> (a, a) -> Maybe (a, a)
encodePair = pairHelper (\x -> if x == 5 then 1 else x + 1)
decodePair = pairHelper (\x -> if x == 1 then 5 else x - 1)

pairHelper :: (Eq t)
    => (Int -> Int) -- ^ a function used for wrapping around the square
    -> Square t -- ^ a playfair square
    -> (t, t) -- ^ two characters
    -> Maybe (t, t) -- ^ the two resulting/encoded characters
pairHelper adjust sqr (c1, c2) =
    do let ps = assocs sqr
       -- assigns an association list of (x-coord * y-coord) * value to ps
       (x1, y1) <- getIndex' c1 ps
       (x2, y2) <- getIndex' c2 ps
       -- returns the coordinates of two values in the square
       -- these will later be swapped
       guard $ c1 /= c2
       -- the characters (and coordinates) cannot be the same
       let get x = sqr ! x
       -- a small utility function for extracting a value from the square
       Just $
           -- wrap the coordinates around and find the encrypted characters
           case () of
             () | y1 == y2 ->
                    (get (adjust x1, y1), get (adjust x2, y2))
                | x1 == x2 ->
                    (get (x1, adjust y1), get (x2, adjust y2))
                | otherwise ->
                    (get (x1, y2), get (x2, y1))

-- | Turns two characters into a tuple.
parsePair :: String -> [(Char, Char)]
parsePair = fmap (\[x, y] -> (x, y)) . words . fmap toUpper

-- | Turns a tuple of two characters into a string.
unparsePair :: [(Char, Char)] -> String
unparsePair = unwords . fmap (\(x, y) -> [x, y])

codeHelper :: (Square Char -> (Char, Char) -> Maybe (Char, Char))
    -> String -> String -> Maybe String
codeHelper subs key =
    fmap unparsePair .
    mapM (subs (makeSquare $ makeTable key)) .
    parsePair

playfair, unplayfair :: String -> String -> Maybe String
playfair key = codeHelper encodePair key . formatEncode
unplayfair = codeHelper decodePair

formatEncode :: String -> String
formatEncode =
    map toUpper .
    unwords .
    map (\[x, y] -> if x == y then [x, 'x'] else [x, y]) .
    chunksOf 2 .
    replace "j" "i" .
    concatMap adjustLength .
    words .
    filter (\n -> n `elem` (['A'..'Z'] ++ ['a'..'z']))
    where
      adjustLength str
          | odd (length str) = str ++ "x"
          | otherwise = str

>>> playfair "playfair example" "hide the gold in the tree stump"
Just "BM OD ZB XD NA BE KU DM UI XM KZ ZR YI"

>>> unplayfair "playfair example" "BM OD ZB XD NA BE KU DM UI XM KZ ZR YI"
Just "HI DE TH EG OL DI NT HE TR EX ST UM PX"

Implement a Playfair cipher for both encryption and decryption. The user has the option to replace 'J' with 'I' or exclude 'Q' from the alphabet. The resulting encrypted and decrypted messages are displayed in capitalized digraphs, separated by spaces.


{-# LANGUAGE FlexibleContexts #-}
import Data.Array
import Data.Array.MArray
import Data.Array.ST
import Control.Monad.ST
import Control.Monad (foldM)
import Data.Set as S

dijkstra :: (Ix v, Num w, Ord w, Bounded w) => v -> v -> Array v [(v,w)] -> (Array v w, Array v v)
dijkstra src invalid_index adj_list = runST $ do
  min_distance <- newSTArray b maxBound
  writeArray min_distance src 0
  previous <- newSTArray b invalid_index
  let aux vertex_queue =
        case S.minView vertex_queue of
          Nothing -> return ()
          Just ((dist, u), vertex_queue') ->
            let edges = adj_list ! u
                f vertex_queue (v, weight) = do
                  let dist_thru_u = dist + weight
                  old_dist <- readArray min_distance v
                  if dist_thru_u >= old_dist then
                    return vertex_queue
                  else do
                    let vertex_queue' = S.delete (old_dist, v) vertex_queue
                    writeArray min_distance v dist_thru_u
                    writeArray previous v u
                    return $ S.insert (dist_thru_u, v) vertex_queue'
            in
            foldM f vertex_queue' edges >>= aux  -- note that aux is being called within its own definition (i.e. aux is recursive). The foldM only iterates on the neighbours of v, it does not execute the while loop itself in Dijkstra's
  aux (S.singleton (0, src))
  m <- freeze min_distance
  p <- freeze previous
  return (m, p)
  where b = bounds adj_list
        newSTArray :: Ix i => (i,i) -> e -> ST s (STArray s i e)
        newSTArray = newArray

shortest_path_to :: (Ix v) => v -> v -> Array v v -> [v]
shortest_path_to target invalid_index previous =
  aux target [] where
    aux vertex acc | vertex == invalid_index = acc
                   | otherwise = aux (previous ! vertex) (vertex : acc)

adj_list :: Array Char [(Char, Int)]
adj_list = listArray ('a', 'f') [ [('b',7), ('c',9), ('f',14)],
                                  [('a',7), ('c',10), ('d',15)],
                                  [('a',9), ('b',10), ('d',11), ('f',2)],
                                  [('b',15), ('c',11), ('e',6)],
                                  [('d',6), ('f',9)],
                                  [('a',14), ('c',2), ('e',9)] ]

main :: IO ()
main = do
  let (min_distance, previous) = dijkstra 'a' ' ' adj_list
  putStrLn $ "Distance from a to e: " ++ show (min_distance ! 'e')
  let path = shortest_path_to 'e' ' ' previous
  putStrLn $ "Path: " ++ show path

"Implement Dijkstra's algorithm to find the shortest path from a single source to all other vertices 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 inputs. It outputs a set of edges depicting the shortest path to each reachable node from the origin. The code also includes functionality to interpret the output and display the shortest path from a specific node to other specified nodes."


data Tree a
  = Leaf
  | Node
      Int
      (Tree a)
      a
      (Tree a)
  deriving (Show, Eq)

foldTree :: Ord a => [a] -> Tree a
foldTree = foldr insert Leaf

height :: Tree a -> Int
height Leaf = -1
height (Node h _ _ _) = h

depth :: Tree a -> Tree a -> Int
depth a b = succ (max (height a) (height b))

insert :: Ord a => a -> Tree a -> Tree a
insert v Leaf = Node 1 Leaf v Leaf
insert v t@(Node n left v_ right)
  | v_ < v = rotate $ Node n left v_ (insert v right)
  | v_ > v = rotate $ Node n (insert v left) v_ right
  | otherwise = t

max_ :: Ord a => Tree a -> Maybe a
max_ Leaf = Nothing
max_ (Node _ _ v right) =
  case right of
    Leaf -> Just v
    _ -> max_ right

delete :: Ord a => a -> Tree a -> Tree a
delete _ Leaf = Leaf
delete x (Node h left v right)
  | x == v =
    maybe left (rotate . (Node h left <*> (`delete` right))) (max_ right)
  | x > v = rotate $ Node h left v (delete x right)
  | x < v = rotate $ Node h (delete x left) v right

rotate :: Tree a -> Tree a
rotate Leaf = Leaf
rotate (Node h (Node lh ll lv lr) v r)
  -- Left Left.
  | lh - height r > 1 && height ll - height lr > 0 =
    Node lh ll lv (Node (depth r lr) lr v r)
rotate (Node h l v (Node rh rl rv rr))
  -- Right Right.
  | rh - height l > 1 && height rr - height rl > 0 =
    Node rh (Node (depth l rl) l v rl) rv rr
rotate (Node h (Node lh ll lv (Node rh rl rv rr)) v r)
  -- Left Right.
  | lh - height r > 1 =
    Node h (Node (rh + 1) (Node (lh - 1) ll lv rl) rv rr) v r
rotate (Node h l v (Node rh (Node lh ll lv lr) rv rr))
  -- Right Left.
  | rh - height l > 1 =
    Node h l v (Node (lh + 1) ll lv (Node (rh - 1) lr rv rr))
rotate (Node h l v r) =
  -- Re-weighting.
  let (l_, r_) = (rotate l, rotate r)
   in Node (depth l_ r_) l_ v r_

draw :: Show a => Tree a -> String
draw t = '\n' : draw_ t 0 <> "\n"
  where
    draw_ Leaf _ = []
    draw_ (Node h l v r) d = draw_ r (d + 1) <> node <> draw_ l (d + 1)
      where
        node = padding d <> show (v, h) <> "\n"
        padding n = replicate (n * 4) ' '

main :: IO ()
main = putStr $ draw $ foldTree [1 .. 31]

implement an AVL tree with basic operations. The AVL tree is a self-balancing binary search tree where the heights of the two child subtrees of any node differ by at most one. The tree rebalances itself after each insertion or deletion to maintain this property. The basic operations including lookup, insertion, and deletion all take O(log n) time. The tree does not allow duplicate node keys. The implementation is based on the solution of homework #4 from the course at http://www.seas.upenn.edu/~cis194/spring13/lectures.html.


add (a, b) (x, y) = (a + x, b + y)
sub (a, b) (x, y) = (a - x, b - y)
magSqr (a, b)     = (a ^^ 2) + (b ^^ 2)
mag a             = sqrt $ magSqr a
mul (a, b) c      = (a * c, b * c)
div2 (a, b) c     = (a / c, b / c)
perp (a, b)       = (negate b, a)
norm a            = a `div2` mag a

circlePoints :: (Ord a, Floating a) =>
                (a, a) -> (a, a) -> a -> Maybe ((a, a), (a, a))
circlePoints p q radius
  | radius == 0      = Nothing
  | p == q           = Nothing
  | diameter < magPQ = Nothing
  | otherwise        = Just (center1, center2)
  where
    diameter = radius * 2
    pq       = p `sub` q
    magPQ    = mag pq
    midpoint = (p `add` q) `div2` 2
    halfPQ   = magPQ / 2
    magMidC  = sqrt . abs $ (radius ^^ 2) - (halfPQ ^^ 2)
    midC     = (norm $ perp pq) `mul` magMidC
    center1  = midpoint `add` midC
    center2  = midpoint `sub` midC

uncurry3 f (a, b, c) = f a b c

main :: IO ()
main = mapM_ (print . uncurry3 circlePoints)
  [((0.1234, 0.9876), (0.8765, 0.2345), 2),
   ((0     , 2     ), (0     , 0     ), 1),
   ((0.1234, 0.9876), (0.1234, 0.9876), 2),
   ((0.1234, 0.9876), (0.8765, 0.2345), 0.5),
   ((0.1234, 0.9876), (0.1234, 0.1234), 0)]

"Function to calculate two possible circles given two points and a radius in 2D space. The function handles special cases such as when radius is zero, points are coincident, points form a diameter, or points are too distant. The function returns the circles or a special indication when two equal or distinct circles cannot be returned."


import Control.Monad
import System.Random

loopBreak n k = do
  r <- randomRIO (0,n)
  print r
  unless (r==k) $ do
    print =<< randomRIO (0,n)
    loopBreak n k

loopBreak 19 10

Generates and prints random numbers from 0 to 19. If the first generated number is 10, the loop stops. If not, a second random number is generated and printed before the loop restarts. If 10 is never the first number, the loop continues indefinitely.


import Data.List
import HFM.Primes (isPrime)
import Control.Monad
import Control.Arrow

int2bin = reverse.unfoldr(\x -> if x==0 then Nothing
                                else Just ((uncurry.flip$(,))$divMod x 2))

trialfac m = take 1. dropWhile ((/=1).(\q -> foldl (((`mod` q).).pm) 1 bs)) $ qs
  where qs = filter (liftM2 (&&) (liftM2 (||) (==1) (==7) .(`mod`8)) isPrime ).
              map (succ.(2*m*)). enumFromTo 1 $ m `div` 2
        bs = int2bin m
        pm n b = 2^b*n*n

*Main> trialfac 929
[13007]

The code implements a method to find a factor of a Mersenne number, specifically 2^929-1 (M929). It uses the modPow operation to determine if a number divides 2^P-1. The code also uses the properties of Mersenne numbers to refine the process, where any factor q of 2^P-1 must be of the form 2kP+1 and must be 1 or 7 mod 8. The algorithm stops when 2kP+1 > sqrt(N). The code utilizes the Primes module by David Amos for prime number testing.


import Data.List
import Control.Arrow
import Control.Monad

takeWhileIncl           :: (a -> Bool) -> [a] -> [a]
takeWhileIncl _ []      =  []
takeWhileIncl p (x:xs)
            | p x       =  x : takeWhileIncl p xs
            | otherwise =  [x]

getmultiLineItem n = takeWhileIncl(not.isInfixOf ("</" ++ n)). dropWhile(not.isInfixOf ('<': n))
getsingleLineItems n = map (takeWhile(/='<'). drop 1. dropWhile(/='>')). filter (isInfixOf ('<': n))

main = do
  xml <- readFile "./Rosetta/xmlpath.xml"
  let xmlText = lines xml

  putStrLn "\n== First item ==\n"
  mapM_ putStrLn $ head $ unfoldr (Just. liftM2 (id &&&) (\\) (getmultiLineItem "item")) xmlText

  putStrLn "\n== Prices ==\n"
  mapM_ putStrLn $ getsingleLineItems "price" xmlText

  putStrLn "\n== Names ==\n"
  print $ getsingleLineItems "name" xmlText

{-# LANGUAGE Arrows #-}
import Text.XML.HXT.Arrow
{- For HXT version >= 9.0, use instead:
import Text.XML.HXT.Core
-}

deepElem name = deep (isElem >>> hasName name)

process = proc doc -> do
  item <- single (deepElem "item") -< doc
  _ <- listA (arrIO print <<< deepElem "price") -< doc
  names <- listA (deepElem "name") -< doc
  returnA -< (item, names)

main = do
  [(item, names)] <- runX (readDocument [] "xmlpath.xml" >>> process)
  print item
  print names

The code performs three XPath queries on a given XML document. It retrieves the first "item" element, prints out each "price" element, and creates an array of all the "name" elements. The operations are performed using the Haskell XML Toolkit (HXT).


Works with: GHC

Prelude> import Data.Set
Prelude Data.Set> empty :: Set Integer -- Empty set
fromList []
Prelude Data.Set> let s1 = fromList [1,2,3,4,3] -- Convert list into set
Prelude Data.Set> s1
fromList [1,2,3,4]
Prelude Data.Set> let s2 = fromList [3,4,5,6]
Prelude Data.Set> union s1 s2 -- Union
fromList [1,2,3,4,5,6]
Prelude Data.Set> intersection s1 s2 -- Intersection
fromList [3,4]
Prelude Data.Set> s1 \\ s2 -- Difference
fromList [1,2]
Prelude Data.Set> s1 `isSubsetOf` s1 -- Subset
True
Prelude Data.Set> fromList [3,1] `isSubsetOf` s1
True
Prelude Data.Set> s1 `isProperSubsetOf` s1 -- Proper subset
False
Prelude Data.Set> fromList [3,1] `isProperSubsetOf` s1
True
Prelude Data.Set> fromList [3,2,4,1] == s1 -- Equality
True
Prelude Data.Set> s1 == s2
False
Prelude Data.Set> 2 `member` s1 -- Membership
True
Prelude Data.Set> 10 `notMember` s1
True
Prelude Data.Set> size s1 -- Cardinality
4
Prelude Data.Set> insert 99 s1 -- Create a new set by inserting
fromList [1,2,3,4,99]
Prelude Data.Set> delete 3 s1 -- Create a new set by deleting
fromList [1,2,4]

Prelude> import Data.List
Prelude Data.List> let s3 = nub [1,2,3,4,3] -- Remove duplicates from list
Prelude Data.List> s3
[1,2,3,4]
Prelude Data.List> let s4 = [3,4,5,6]
Prelude Data.List> union s3 s4 -- Union
[1,2,3,4,5,6]
Prelude Data.List> intersect s3 s4 -- Intersection
[3,4]
Prelude Data.List> s3 \\ s4 -- Difference
[1,2]
Prelude Data.List> 42 : s3 -- Return new list with element inserted at the beginning
[42,1,2,3,4]
Prelude Data.List> delete 3 s3 -- Return new list with first occurrence of element removed
[1,2,4]

implement a set data structure with operations including set creation, checking if an element is in a set, union, intersection, difference, subset, and equality of sets. Optional operations include other set operations and modification of a mutable set. The set can be implemented using an associative array, a binary search tree, a hash table, or an ordered array of binary bits. The code also includes the functionality of using regular lists as sets with some helper functions. The code uses GHC's Data.Set module for a functional, persistent set data structure.


import Data.Time (fromGregorian)
import Data.Time.Calendar.WeekDate (toWeekDate)

--------------------- DAY OF THE WEEK --------------------

isXmasSunday :: Integer -> Bool
isXmasSunday year = 7 == weekDay
  where
    (_, _, weekDay) = toWeekDate $ fromGregorian year 12 25

--------------------------- TEST -------------------------
main :: IO ()
main =
  mapM_
    putStrLn
    [ "Sunday 25 December " <> show year
      | year <- [2008 .. 2121],
        isXmasSunday year
    ]

The code determines the years between 2008 and 2121 where Christmas falls on a Sunday, using standard date handling libraries. It also compares the results with other languages to identify any date/time handling anomalies, such as overflow issues similar to the y2k problem. The code also acknowledges the potential for overflow in the System.Time module at the Unix epoch in 2038 on 64-bit systems running current versions of GHC.


import Data.List
import Text.Printf (printf)

eps = 1e-6 :: Double

-- a matrix is represented as a list of columns
mmult :: Num a => [[a]] -> [[a]] -> [[a]]
nth :: Num a => [[a]] -> Int -> Int -> a
mmult_num :: Num a => [[a]] -> a -> [[a]]
madd :: Num a => [[a]] -> [[a]] -> [[a]]
idMatrix :: Num a => Int -> Int -> [[a]]

adjustWithE :: [[Double]] -> Int -> [[Double]]

mmult a b = [ [ sum $ zipWith (*) ak bj | ak <- (transpose a) ] | bj <- b ]
nth mA i j = (mA !! j) !! i
mmult_num mA n = map (\c -> map (*n) c) mA
madd mA mB = zipWith (\c1 c2 -> zipWith (+) c1 c2) mA mB
idMatrix n m = [ [if (i==j) then 1 else 0 | i <- [1..n]] | j <- [1..m]]

adjustWithE mA n = let lA = length mA in
    (idMatrix n (n - lA)) ++ (map (\c -> (take (n - lA) (repeat 0.0)) ++ c ) mA)

-- auxiliary functions
sqsum :: Floating a => [a] -> a
norm :: Floating a => [a] -> a
epsilonize :: [[Double]] -> [[Double]]

sqsum a = foldl (\x y -> x + y*y) 0 a
norm a = sqrt $! sqsum a
epsilonize mA = map (\c -> map (\x -> if abs x <= eps then 0 else x) c) mA

-- Householder transformation; householder A = (Q, R)
uTransform :: [Double] -> [Double]
hMatrix :: [Double] -> Int -> Int -> [[Double]]
householder :: [[Double]] -> ([[Double]], [[Double]])

-- householder_rec Q R A
householder_rec :: [[Double]] -> [[Double]] -> Int -> ([[Double]], [[Double]])

uTransform a = let t = (head a) + (signum (head a))*(norm a) in
    1 : map (\x -> x/t) (tail a)

hMatrix a n i = let u = uTransform (drop i a) in
    madd
        (idMatrix (n-i) (n-i))
        (mmult_num
            (mmult [u] (transpose [u]))
            ((/) (-2) (sqsum u)))

householder_rec mQ mR 0 = (mQ, mR)
householder_rec mQ mR n = let mSize = length mR in
    let mH = adjustWithE (hMatrix (mR!!(mSize - n)) mSize (mSize - n)) mSize in
        householder_rec (mmult mQ mH) (mmult mH mR) (n - 1)

householder mA = let mSize = length mA in
    let (mQ, mR) = householder_rec (idMatrix mSize mSize) mA mSize in
        (epsilonize mQ, epsilonize mR)

backSubstitution :: [[Double]] -> [Double] -> [Double] -> [Double]
backSubstitution mR [] res = res
backSubstitution mR@(hR:tR) q@(h:t) res =
    let x = (h / (head hR)) in
        backSubstitution
            (map tail tR)
            (tail (zipWith (-) q (map (*x) hR)))
            (x : res)

showMatrix :: [[Double]] -> String
showMatrix mA =
    concat $ intersperse "\n"
        (map (\x -> unwords $ printf "%10.4f" <$> (x::[Double])) (transpose mA))

mY = [[12, 6, -4], [-51, 167, 24], [4, -68, -41]] :: [[Double]]
q = [21, 245, 35] :: [Double]
main = let (mQ, mR) = householder mY in
    putStrLn ("Q: \n" ++ showMatrix mQ) >>
    putStrLn ("R: \n" ++ showMatrix mR) >>
    putStrLn ("q: \n" ++ show q) >>
    putStrLn ("x: \n" ++ show (backSubstitution (reverse (map reverse mR)) (reverse q) []))

Implement QR decomposition using Householder reflections. The code takes a rectangular matrix and decomposes it into a product of an orthogonal matrix and an upper triangular matrix. It also demonstrates the QR decomposition on a given example matrix and uses it to solve linear least squares problems. The code handles the case when the matrix is not square by cutting off the zero padded bottom rows. It finally solves the square upper triangular system by back substitution.


 print $ unique [4, 5, 4, 2, 3, 3, 4]

[4,5,2,3]

import qualified Data.Set as Set

unique :: Ord a => [a] -> [a]
unique = Set.toList . Set.fromList

import Data.Set

unique :: Ord a => [a] -> [a]
unique = loop empty
  where
    loop s []                    = []
    loop s (x : xs) | member x s = loop s xs
                    | otherwise  = x : loop (insert x s) xs

import Data.List

unique :: Eq a => [a] -> [a]
unique []       = []
unique (x : xs) = x : unique (filter (x /=) xs)

import Data.List
Data.List.nub :: Eq a => [a] -> [a]
Data.List.Unique.unique :: Ord a => [a] -> [a]

implement three methods to remove duplicate elements from an array:

1. Using a hash table to eliminate duplicates, with an average complexity of O(n) and worst-case complexity of O(n^2).
2. Sorting the array and removing consecutive duplicates, with a complexity of O(n log n).
3. Iterating through the array and discarding any element that appears more than once, with a complexity of O(n^2).

The first two methods require a partial ordering of elements, whereas the third only requires that elements can be compared for equality.


qsort [] = []
qsort (x:xs) = qsort [y | y <- xs, y < x] ++ [x] ++ qsort [y | y <- xs, y >= x]

import Data.List (partition)

qsort :: Ord a => [a] -> [a]
qsort [] = []
qsort (x:xs) = qsort ys ++ [x] ++ qsort zs where
    (ys, zs) = partition (< x) xs

implement a quicksort algorithm to sort an array or list of elements. The algorithm selects a pivot element and divides 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 both partitions and merges them with the pivot. The codes also include an optimized version of quicksort that works in place by swapping elements within the array to save memory allocation. The pivot selection method is not specified and can vary.


import Data.Time
       (FormatTime, formatTime, defaultTimeLocale, utcToLocalTime,
        getCurrentTimeZone, getCurrentTime)

formats :: FormatTime t => [t -> String]
formats = (formatTime defaultTimeLocale) <$>  ["%F", "%A, %B %d, %Y"]

main :: IO ()
main = do
  t <- pure utcToLocalTime <*> getCurrentTimeZone <*> getCurrentTime
  putStrLn $ unlines (formats <*> pure t)

2017-06-05
Monday, June 05, 2017

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


import Data.Set
import Control.Monad

powerset :: Ord a => Set a -> Set (Set a)
powerset = fromList . fmap fromList . listPowerset . toList

listPowerset :: [a] -> [[a]]
listPowerset = filterM (const [True, False])

powerset [] = [[]]
powerset (head:tail) = acc ++ map (head:) acc where acc = powerset tail

powerSet :: [a] -> [[a]]
powerSet = foldr (\x acc -> acc ++ map (x:) acc) [[]]

powerSet :: [a] -> [[a]]
powerSet = foldr ((mappend <*>) . fmap . (:)) (pure [])

*Main> listPowerset [1,2,3]
[[1,2,3],[1,2],[1,3],[1],[2,3],[2],[3],[]]
*Main> powerset (Data.Set.fromList [1,2,3])
{{},{1},{1,2},{1,2,3},{1,3},{2},{2,3},{3}}

Works with: GHC version 6.10
Prelude> import Data.List
Prelude Data.List> subsequences [1,2,3]
[[],[1],[2],[1,2],[3],[1,3],[2,3],[1,2,3]]

import qualified Data.Set as Set
type Set=Set.Set
unionAll :: (Ord a) => Set (Set a) -> Set a
unionAll = Set.fold Set.union Set.empty

--slift is the analogue of liftA2 for sets.
slift :: (Ord a, Ord b, Ord c) => (a->b->c) -> Set a -> Set b -> Set c
slift f s0 s1 = unionAll (Set.map (\e->Set.map (f e) s1) s0)

--a -> {{},{a}}
makeSet :: (Ord a) => a -> Set (Set a)
makeSet = (Set.insert Set.empty) . Set.singleton.Set.singleton

powerSet :: (Ord a) => Set a -> Set (Set a)
powerSet = (Set.fold (slift Set.union) (Set.singleton Set.empty)) . Set.map makeSet

Prelude Data.Set> powerSet fromList [1,2,3]
fromList [fromList [], fromList [1], fromList [1,2], fromList [1,2,3], fromList [1,3], fromList [2], fromList [2,3], fromList [3]]

The code takes a set S as input and generates the power set of S. It can either use a built-in set type or define a set type with necessary operations. The power set includes all possible subsets of the input set, including the empty set. The code also demonstrates the ability to handle power sets of the empty set and the set containing only the empty set. An alternate solution uses set operations and set mapping.


digit :: Char -> Char -> Char -> Integer -> String
digit x y z k =
  [[x], [x, x], [x, x, x], [x, y], [y], [y, x], [y, x, x], [y, x, x, x], [x, z]] !!
  (fromInteger k - 1)

toRoman :: Integer -> String
toRoman 0 = ""
toRoman x
  | x < 0 = error "Negative roman numeral"
toRoman x
  | x >= 1000 = 'M' : toRoman (x - 1000)
toRoman x
  | x >= 100 = digit 'C' 'D' 'M' q ++ toRoman r
  where
    (q, r) = x `divMod` 100
toRoman x
  | x >= 10 = digit 'X' 'L' 'C' q ++ toRoman r
  where
    (q, r) = x `divMod` 10
toRoman x = digit 'I' 'V' 'X' x

main :: IO ()
main = print $ toRoman <$> [1999, 25, 944]

The code takes a positive integer as input and returns its Roman numeral representation as a string. It processes each digit separately, starting from the leftmost digit and ignoring zeros. The code also includes a function, romanFromInt, which uses mapAccumL for explicit decimal digit representation. It also abstracts Roman patterns and applies a simple logic programming idiom.


import Data.Array.IO

main = do arr <- newArray (1,10) 37 :: IO (IOArray Int Int)
          a <- readArray arr 1
          writeArray arr 1 64
          b <- readArray arr 1
          print (a,b)

demonstrate the basic syntax of arrays in a specific programming language. They include creating an array, assigning a value to it, and retrieving an element from it. Both fixed-length and dynamic arrays are shown, with a value being pushed into the latter. The codes also incorporate elements from previous tasks related to array creation, value assignment, and element retrieval.


main = readFile "input.txt" >>= writeFile "output.txt"

demonstrate reading the contents of "input.txt" file into a variable, and then writing these contents into a new file called "output.txt". The process does not keep the file in memory due to buffering provided by lazy evaluation. The code does not use oneliners that skip the intermediate variable.


import Data.Char

s = "alphaBETA"

lower = map toLower s
upper = map toUpper s

demonstrate the conversion of the string "alphaBETA" to upper-case and lower-case using the default string literal or ASCII encoding. The code also showcases additional case conversion functions such as swapping case or capitalizing the first letter if available in the language's library. Note that in some languages, the toLower and toUpper functions may not be reversible.


import Data.List (minimumBy, tails, unfoldr, foldl1') --'

import System.Random (newStdGen, randomRs)

import Control.Arrow ((&&&))

import Data.Ord (comparing)

vecLeng [[a, b], [p, q]] = sqrt $ (a - p) ^ 2 + (b - q) ^ 2

findClosestPair =
  foldl1'' ((minimumBy (comparing vecLeng) .) . (. return) . (:)) .
  concatMap (\(x:xs) -> map ((x :) . return) xs) . init . tails

testCP = do
  g <- newStdGen
  let pts :: [[Double]]
      pts = take 1000 . unfoldr (Just . splitAt 2) $ randomRs (-1, 1) g
  print . (id &&& vecLeng) . findClosestPair $ pts

main = testCP

foldl1'' = foldl1'

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), iterating through all possible pairs to find the minimum distance. The second solution uses a recursive divide-and-conquer approach with a time complexity of O(n log n), sorting the points by x and y coordinates, dividing the set into two halves, and recursively finding the closest pairs in each half. The code then compares the closest pairs from both halves and a strip in the middle to find the overall closest pair.


[1, 2, 3, 4, 5]

1 : [2, 3, 4]

[1, 2] ++ [3, 4]

concat [[1, 2], [3, 4], [5, 6, 7]]

import Data.Array (Array, listArray, Ix, (!))

triples :: Array Int (Char, String, String)
triples =
  listArray (0, 11) $
  zip3
    "鼠牛虎兔龍蛇馬羊猴鸡狗豬" -- 生肖 shengxiao – symbolic animals
    (words "shǔ niú hǔ tù lóng shé mǎ yáng hóu jī gǒu zhū")
    (words "rat ox tiger rabbit dragon snake horse goat monkey rooster dog pig")

indexedItem
  :: Ix i
  => Array i (Char, String, String) -> i -> String
indexedItem a n =
  let (c, w, w1) = a ! n
  in c : unwords ["\t", w, w1]

main :: IO ()
main = (putStrLn . unlines) $ indexedItem triples <$> [2, 4, 6]

create a collection and add values to it. It includes operations like prepending an element to a list, concatenating two lists, concatenating a list of lists, retrieving by index, key-value indexing, and efficient set operations. The code also considers different collection types for efficiency and flexible access.


import Data.List (maximumBy)
import Data.Ord (comparing)

(maxWgt, maxVol) = (25, 0.25)
items =
   [Bounty  "panacea"  3000  0.3  0.025,
    Bounty  "ichor"    1800  0.2  0.015,
    Bounty  "gold"     2500  2.0  0.002]

data Bounty = Bounty
   {itemName :: String,
    itemVal :: Int,
    itemWgt, itemVol :: Double}

names = map itemName items
vals = map itemVal items
wgts = map itemWgt items
vols = map itemVol items

dotProduct :: (Num a, Integral b) => [a] -> [b] -> a
dotProduct factors = sum . zipWith (*) factors . map fromIntegral

options :: [[Int]]
options = filter fits $ mapM f items
  where f (Bounty _ _ w v) = [0 .. m]
          where m = floor $ min (maxWgt / w) (maxVol / v)
        fits opt = dotProduct wgts opt <= maxWgt &&
                   dotProduct vols opt <= maxVol

showOpt :: [Int] -> String
showOpt opt = concat (zipWith showItem names opt) ++
    "total weight: " ++ show (dotProduct wgts opt) ++
    "\ntotal volume: " ++ show (dotProduct vols opt) ++
    "\ntotal value: " ++ show (dotProduct vals opt) ++ "\n"
  where showItem name num = name ++ ": " ++ show num ++ "\n"

main = putStr $ showOpt $ best options
  where best = maximumBy $ comparing $ dotProduct vals

panacea: 9
ichor: 0
gold: 11
total weight: 24.7
total volume: 0.247
total value: 54500

"Generate a brute-force solution to the unbounded Knapsack problem, where a traveler in Shangri La can take as many items as he can carry and fit in his knapsack, with the goal of maximizing the total value of the items. The code generates all possible combinations of items, ensuring the total weight and volume do not exceed the knapsack's capacity, and then selects the combination with the highest total value."


main :: IO ()
main = forM_ [1 .. 10] $ \n -> do
            putStr $ show n
            putStr $ if n == 10 then "\n" else ", "

intercalate ", " (map show [1..10])

The code generates a comma-separated list of numbers from 1 to 10, using separate output statements for the number and the comma within the loop body. It also demonstrates how to execute only part of the loop body in the last iteration.


import Data.List ((\\), elemIndex, intersect, nub)
import Data.Bifunctor (bimap, first)

combs 0 _ = [[]]
combs _ [] = []
combs k (x:xs) = ((x :) <$> combs (k - 1) xs) ++ combs k xs

depLibs :: [(String, String)]
depLibs =
  [ ( "des_system_lib"
    , "std synopsys std_cell_lib des_system_lib dw02 dw01 ramlib ieee")
  , ("dw01", "ieee dw01 dware gtech")
  , ("dw02", "ieee dw02 dware")
  , ("dw03", "std synopsys dware dw03 dw02 dw01 ieee gtech")
  , ("dw04", "dw04 ieee dw01 dware gtech")
  , ("dw05", "dw05 ieee dware")
  , ("dw06", "dw06 ieee dware")
  , ("dw07", "ieee dware")
  , ("dware", "ieee dware")
  , ("gtech", "ieee gtech")
  , ("ramlib", "std ieee")
  , ("std_cell_lib", "ieee std_cell_lib")
  , ("synopsys", [])
  ]

toposort :: [(String, String)] -> [String]
toposort xs
  | (not . null) cycleDetect =
    error $ "Dependency cycle detected for libs " ++ show cycleDetect
  | otherwise = foldl makePrecede [] dB
  where
    dB = (\(x, y) -> (x, y \\ x)) . bimap return words <$> xs
    makePrecede ts ([x], xs) =
      nub $
      case elemIndex x ts of
        Just i -> uncurry (++) $ first (++ xs) $ splitAt i ts
        _ -> ts ++ xs ++ [x]
    cycleDetect =
      filter ((> 1) . length) $
      (\[(a, as), (b, bs)] -> (a `intersect` bs) ++ (b `intersect` as)) <$>
      combs 2 dB

main :: IO ()
main = print $ toposort depLibs

The code implements a function that performs a topological sort on VHDL libraries based on their dependencies. It ensures that no library is compiled before the ones it depends on. The function also handles cases of self-dependencies and flags un-orderable dependencies. It uses either Kahn's 1962 topological sort or depth-first search algorithm for sorting.


> import Data.List
> "abc" `isPrefixOf` "abcdefg"
True
> "efg" `isSuffixOf` "abcdefg"
True
> "bcd" `isInfixOf` "abcdefg"
True
> "abc" `isInfixOf` "abcdefg" -- Prefixes and suffixes are also infixes
True
> let infixes a b = findIndices (isPrefixOf a) $ tails b
> infixes "ab" "abcdefabqqab"
[0,6,10]

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.


import Data.List
import Control.Monad

perms :: (Eq a) => [a] -> [[a]]
perms [] = [[]]
perms xs = [ x:xr | x <- xs, xr <- perms (xs\\[x]) ]

combs :: (Eq a) => Int -> [a] -> [[a]]
combs 0 _ = [[]]
combs n xs = [ x:xr | x <- xs, xr <- combs (n-1) xs ]

ringCheck :: [Int] -> Bool
ringCheck [x0, x1, x2, x3, x4, x5, x6] =
          v == x1+x2+x3
       && v == x3+x4+x5
       && v == x5+x6
    where v = x0 + x1

fourRings :: Int -> Int -> Bool -> Bool -> IO ()
fourRings low high allowRepeats verbose = do
    let candidates = if allowRepeats
                     then combs 7 [low..high]
                     else perms [low..high]

        solutions = filter ringCheck candidates

    when verbose $ mapM_ print solutions

    putStrLn $    show (length solutions)
               ++ (if allowRepeats then " non" else "")
               ++ " unique solutions for "
               ++ show low
               ++ " to "
               ++ show high

    putStrLn ""

main = do
   fourRings 1 7 False True
   fourRings 3 9 False True
   fourRings 0 9 True False

The code finds all possible solutions for a 4-rings or 4-squares puzzle where each square sums up to the same total. It replaces letters a-g with unique decimal digits from a given range (LOW to HIGH). It provides solutions for two specific ranges, LOW=1, HIGH=7 and LOW=3, HIGH=9. Additionally, it calculates the total number of solutions when digits can be non-unique within the range LOW=0, HIGH=9. The code uses a nested search approach for faster performance.


Library: ansi-terminal
import Control.Concurrent
import Data.List
import System.Time

-- Library: ansi-terminal
import System.Console.ANSI

number :: (Integral a) => a -> [String]
number 0 =
  ["██████"
  ,"██  ██"
  ,"██  ██"
  ,"██  ██"
  ,"██████"]
number 1 =
  ["    ██"
  ,"    ██"
  ,"    ██"
  ,"    ██"
  ,"    ██"]
number 2 =
  ["██████"
  ,"    ██"
  ,"██████"
  ,"██    "
  ,"██████"]
number 3 =
  ["██████"
  ,"    ██"
  ,"██████"
  ,"    ██"
  ,"██████"]
number 4 =
  ["██  ██"
  ,"██  ██"
  ,"██████"
  ,"    ██"
  ,"    ██"]
number 5 =
  ["██████"
  ,"██    "
  ,"██████"
  ,"    ██"
  ,"██████"]
number 6 =
  ["██████"
  ,"██    "
  ,"██████"
  ,"██  ██"
  ,"██████"]
number 7 =
  ["██████"
  ,"    ██"
  ,"    ██"
  ,"    ██"
  ,"    ██"]
number 8 =
  ["██████"
  ,"██  ██"
  ,"██████"
  ,"██  ██"
  ,"██████"]
number 9 =
  ["██████"
  ,"██  ██"
  ,"██████"
  ,"    ██"
  ,"██████"]

colon :: [String]
colon =
  ["      "
  ,"  ██  "
  ,"      "
  ,"  ██  "
  ,"      "]

newline :: [String]
newline =
  ["\n"
  ,"\n"
  ,"\n"
  ,"\n"
  ,"\n"]

space :: [String]
space =
  [" "
  ," "
  ," "
  ," "
  ," "]

leadingZero :: (Integral a) => a -> [[String]]
leadingZero num =
  let (tens, ones) = divMod num 10
  in [number tens, space, number ones]

fancyTime :: CalendarTime -> String
fancyTime time =
  let hour   = leadingZero $ ctHour time
      minute = leadingZero $ ctMin time
      second = leadingZero $ ctSec time
      nums   = hour ++ [colon] ++ minute ++ [colon] ++ second ++ [newline]
  in concat $ concat $ transpose nums

main :: IO ()
main = do
  time <- getClockTime >>= toCalendarTime
  putStr $ fancyTime time
  threadDelay 1000000
  setCursorColumn 0
  cursorUp 5
  main

illustrate a time-keeping device that updates every second and cycles periodically. It is designed to be simple, efficient, and not to overuse CPU resources by avoiding unnecessary system timer polling. The time displayed aligns with the system clock. Both text-based and graphical representations are supported.


pytr :: Int -> [(Bool, Int, Int, Int)]
pytr n =
  filter
    (\(_, a, b, c) -> a + b + c <= n)
    [ (prim a b c, a, b, c)
      | a <- xs,
        b <- drop a xs,
        c <- drop b xs,
        a ^ 2 + b ^ 2 == c ^ 2
    ]
  where
    xs = [1 .. n]
    prim a b _ = gcd a b == 1

main :: IO ()
main =
  putStrLn $
    "Up to 100 there are "
      <> show (length xs)
      <> " triples, of which "
      <> show (length $ filter (\(x, _, _, _) -> x) xs)
      <> " are primitive."
  where
    xs = pytr 100

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


Using Library: HGL from HackageDB.

import Graphics.HGL

aWindow =  runGraphics $
  withWindow_ "Rosetta Code task: Creating a window" (300, 200) $ \ w -> do
	drawInWindow w $ text (100, 100) "Hello World"
	getKey w

create a GUI window that can respond to close requests, utilizing a simplified graphics library which provides access to key features of the Win32 Graphics Device Interface and X11 library.


import Data.List (group,sort)
import Control.Arrow ((&&&))
main = interact (show . map (head &&& length) . group . sort)

import Data.List (sortBy)
import qualified Data.Map.Strict as M
import Data.Ord (comparing)

charCounts :: String -> M.Map Char Int
charCounts = foldr (M.alter f) M.empty
  where
    f (Just x) = Just (succ x)
    f _ = Just 1

main :: IO ()
main =
  readFile "miserables.txt"
    >>= mapM_ print
      . sortBy
        (flip $ comparing snd)
      . M.toList
      . charCounts

"Open a text file, count the frequency of each letter, and optionally include punctuation. Alternatively, use a container as an accumulator for a single fold instead of sorting and grouping the entire string."


 data List a = Nil | Cons a (List a)

 data IntList s = Nil | Cons Integer (STRef s (IntList s))

define a data structure for a singly-linked list element. This element holds a numeric value and has a mutable link to the next element. This is not a common practice in Haskell due to its immutability and frequent use of lists with any data member type.


Library: Gloss
import Graphics.Gloss

type Model = [Picture -> Picture]

fractal :: Int -> Model -> Picture -> Picture
fractal n model pict = pictures $ take n $ iterate (mconcat model) pict

tree1 _ = fractal 10 branches $ Line [(0,0),(0,100)]
  where branches = [ Translate 0 100 . Scale 0.75 0.75 . Rotate 30
                   , Translate 0 100 . Scale 0.5 0.5 . Rotate (-30) ]

main = animate (InWindow "Tree" (800, 800) (0, 0)) white $ tree1 . (* 60)

--animated tree
tree2 t = fractal 8 branches $ Line [(0,0),(0,100)]
  where branches = [ Translate 0 100 . Scale 0.75 0.75 . Rotate t
                   , Translate 0 100 . Scale 0.6 0.6 . Rotate 0
                   , Translate 0 100 . Scale 0.5 0.5 . Rotate (-2*t) ]

--animated fractal clock
circles t = fractal 10 model $ Circle 100
  where model = [ Translate 0 50 . Scale 0.5 0.5 . Rotate t
                , Translate 0 (-50) . Scale 0.5 0.5 . Rotate (-2*t) ]

--Pythagoras tree
pithagor _ = fractal 10 model $ rectangleWire 100 100
  where model = [ Translate 50 100 . Scale s s . Rotate 45
                , Translate (-50) 100 . Scale s s . Rotate (-45)]
        s = 1/sqrt 2

--Sierpinski pentagon
pentaflake _ = fractal 5 model $ pentagon
  where model =  map copy [0,72..288]
        copy a = Scale s s . Rotate a . Translate 0 x
        pentagon = Line [ (sin a, cos a) | a <- [0,2*pi/5..2*pi] ]
        x = 2*cos(pi/5)
        s = 1/(1+x)

Library: HGL
import Graphics.HGL.Window
import Graphics.HGL.Run
import Control.Arrow
import Control.Monad
import Data.List

enumBase :: Int -> Int -> [[Int]]
enumBase n = mapM (enumFromTo 0). replicate n. pred

psPlus (a,b) (p,q) = (a+p, b+q)

toInt :: Double -> Int
toInt = fromIntegral.round

intPoint = toInt *** toInt

pts n =
  map (map (intPoint.psPlus (100,0)). ((0,300):). scanl1 psPlus. ((r,300):). zipWith (\h a -> (h*cos a, h*sin a)) rs) hs
  where
    [r,h,sr,sh] = [50, pi/5, 0.9, 0.75]
    rs   = take n $ map (r*) $ iterate(*sr) sr
    lhs  = map (map (((-1)**).fromIntegral)) $ enumBase n 2
    rhs  = take n $ map (h*) $ iterate(*sh) 1
    hs   = map (scanl1 (+). zipWith (*)rhs) lhs

fractalTree :: Int -> IO ()
fractalTree n =
   runWindow "Fractal Tree" (500,600)
    (\w -> setGraphic w (overGraphics ( map polyline $ pts (n-1))) >> getKey w)

main = fractalTree 10

generates a fractal tree by drawing a trunk and then recursively drawing branches at the end of each branch, splitting at a certain angle until a specified level of branching is reached. The code allows for customization of the fractal geometric structures. It also provides an alternative solution using the J contribution method.


import HFM.Primes (primePowerFactors)
import Control.Monad (mapM)
import Data.List (product)

-- primePowerFactors :: Integer -> [(Integer,Int)]

factors = map product .
          mapM (\(p,m)-> [p^i | i<-[0..m]]) . primePowerFactors

~> factors 42
[1,7,3,21,2,14,6,42]

import Data.List (group)
primePowerFactors = map (\x-> (head x, length x)) . group . factorize

integerFactors :: Int -> [Int]
integerFactors n
  | 1 > n = []
  | otherwise = lows <> (quot n <$> part n (reverse lows))
  where
    part n
      | n == square = tail
      | otherwise = id
    (square, lows) =
      (,) . (^ 2)
        <*> (filter ((0 ==) . rem n) . enumFromTo 1)
        $ floor (sqrt $ fromIntegral n)

main :: IO ()
main = print $ integerFactors 600

compute the factors of a positive integer. It uses D. Amos'es Primes module to find prime factors and can also derive cofactors from factors up to the square root. The factors are returned out of order. The code also includes a version that doesn't require sorting and is productive immediately. It doesn't handle the cases of zero or negative integers. It's best suited for numbers of up to 50-60 digits.


import Data.List (unfoldr, transpose)
import Control.Arrow (second)

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

brkdwn =
  takeWhile (not . null) . unfoldr (Just . second (drop 1) . span ('$' /=))

format j ls = map (unwords . zipWith align colw) rows
  where
    rows = map brkdwn $ lines ls
    colw = map (maximum . map length) . transpose $ rows
    align cw w =
      case j of
        'c' -> replicate l ' ' ++ w ++ replicate r ' '
        'r' -> replicate dl ' ' ++ w
        'l' -> w ++ replicate dl ' '
      where
        dl = cw - length w
        (l, r) = (dl `div` 2, dl - l)

The code reads a text file where fields within a line are separated by a dollar character. It aligns each column of fields by ensuring at least one space between words in each column. The words in a column can be left justified, right justified, or center justified. The code handles trailing dollar characters, aligns all columns similarly, ignores consecutive spaces at the end of lines, views output text in a mono-spaced font on a plain text editor or basic terminal, calculates minimum space between columns from the text, and does not require adding separating characters between or around columns.


import Graphics.Rendering.OpenGL
import Graphics.UI.GLUT

-- Draw a cuboid.  Its vertices are those of a unit cube, which is then scaled
-- to the required dimensions.  We only specify the visible faces, each of
-- which is composed of two triangles.  The faces are rotated into position and
-- rendered with a perspective transformation.

type Fl = GLfloat

cuboid :: IO ()
cuboid = do
  color red   ; render front
  color green ; render side
  color blue  ; render top

red,green,blue :: Color4 GLfloat
red   = Color4 1 0 0 1
green = Color4 0 1 0 1
blue  = Color4 0 0 1 1

render :: [(Fl, Fl, Fl)] -> IO ()
render = renderPrimitive TriangleStrip . mapM_ toVertex
  where toVertex (x,y,z) = vertex $ Vertex3 x y z

front,side,top :: [(Fl,Fl,Fl)]
front = vertices [0,1,2,3]
side  = vertices [4,1,5,3]
top   = vertices [3,2,5,6]

vertices :: [Int] -> [(Fl,Fl,Fl)]
vertices = map (verts !!)

verts :: [(Fl,Fl,Fl)]
verts = [(0,0,1), (1,0,1), (0,1,1), (1,1,1), (1,0,0), (1,1,0), (0,1,0)]

transform :: IO ()
transform = do
  translate $ Vector3 0 0 (-10 :: Fl)
  rotate (-14) $ Vector3 0 0 (1 :: Fl)
  rotate (-30) $ Vector3 0 1 (0 :: Fl)
  rotate   25  $ Vector3 1 0 (0 :: Fl)
  scale 2 3 (4 :: Fl)
  translate $ Vector3 (-0.5) (-0.5) (-0.5 :: Fl)

display :: IO ()
display = do
  clear [ColorBuffer]
  perspective 40 1 1 (15 :: GLdouble)
  transform
  cuboid
  flush

main :: IO ()
main = do
  let name = "Cuboid"
  initialize name []
  createWindow name
  displayCallback $= display
  mainLoop

generate a graphical or ASCII art representation of a cuboid with dimensions 2x3x4, showing at least three visible faces, with either static or rotational projection.


{-# LANGUAGE OverloadedStrings #-}

module Main (main) where

import           Data.Foldable (for_)
import qualified Data.Text.Encoding as Text (encodeUtf8)
import           Ldap.Client (Attr(..), Filter(..))
import qualified Ldap.Client as Ldap (Dn(..), Host(..), search, with, typesOnly)

main :: IO ()
main = do
    entries <- Ldap.with (Ldap.Plain "localhost") 389 $ \ldap ->
        Ldap.search ldap (Ldap.Dn "o=example.com") (Ldap.typesOnly True) (Attr "uid" := Text.encodeUtf8 "user") []
    for_ entries $ \entry ->
        print entry

establish a connection to an Active Directory or Lightweight Directory Access Protocol server using the ldap-client package.


import Data.Char (chr, isAlpha, ord, toLower)
import Data.Bool (bool)

rot13 :: Char -> Char
rot13 c
  | isAlpha c = chr $ bool (-) (+) ('m' >= toLower c) (ord c) 13
  | otherwise = c

-- Simple test
main :: IO ()
main = print $ rot13 <$> "Abjurer nowhere"

import Data.Char (chr, isAlpha, ord, toLower)
import Data.Bool (bool)

rot13 :: Char -> Char
rot13 =
  let rot = flip ((bool (-) (+) . ('m' >=) . toLower) <*> ord)
  in (bool <*> chr . rot 13) <*> isAlpha

-- Simple test
main :: IO ()
main = print $ rot13 <$> "Abjurer nowhere"

The code implements a rot-13 function that encodes every line of input from a file or standard input. It also wraps this function in a utility program similar to a common UNIX utility. The rot-13 encoding replaces every ASCII alphabet letter with the letter rotated 13 characters around the 26 letter alphabet. The code maintains the case of the letters and passes all non-alphabetic characters without alteration. The code also includes a framework to wrap the rot13 function as a utility program, which reads the file lazily, providing buffering.


import Data.List
import Data.Function (on)

data Person =
  P String
    Int
  deriving (Eq)

instance Show Person where
  show (P name val) = "Person " ++ name ++ " with value " ++ show val

instance Ord Person where
  compare (P a _) (P b _) = compare a b

pVal :: Person -> Int
pVal (P _ x) = x

people :: [Person]
people = [P "Joe" 12, P "Bob" 8, P "Alice" 9, P "Harry" 2]

main :: IO ()
main = do
  mapM_ print $ sort people
  putStrLn []
  mapM_ print $ sortBy (on compare pVal) people

sort an array of composite structures, specifically name-value pairs, by the key name using a custom comparator. It also includes a general function, sortBy, that sorts a list based on a provided comparison function.


import Control.Monad

main = do
  forM_ [1..5] $ \i -> do
    forM_ [1..i] $ \j -> do
      putChar '*'
    putChar '\n'

import Data.List (inits)

main = mapM_ putStrLn $ tail $ inits $ replicate 5 '*'

putStrLn $ unlines [replicate n '*' | n <- [1..5]]

putStrLn . unlines . take 5 $ iterate ('*':) "*"

The code demonstrates the use of nested for loops. The outer loop controls the number of iterations performed by the inner loop, which in turn prints out a pattern of asterisks. The pattern starts with a single asterisk and increases by one each line. The code also includes alternative Haskell solutions using list comprehension and an infinite stream of increasing length lines.


Works with: GHC
import Data.Map

dict = fromList [("key1","val1"), ("key2","val2")]

ans = Data.Map.lookup "key2" dict  -- evaluates to Just "val2"

dict = [("key1","val1"), ("key2","val2")]

ans = lookup "key2" dict  -- evaluates to Just "val2"

The code creates an associative array, also known as a dictionary, map, or hash. It also demonstrates the use of association lists, which are simple but inefficient due to their O(n) lookup. The code also references the Data.HashTable module, which was removed in GHC 7.8, and other standard associative arrays libraries like Data.IntMap and Data.HasMap.


bsd = tail . iterate (\n -> (n * 1103515245 + 12345) `mod` 2^31)
msr = map (`div` 2^16) . tail . iterate (\n -> (214013 * n + 2531011) `mod` 2^31)

main = do
	print $ take 10 $ bsd 0 -- can take seeds other than 0, of course
	print $ take 10 $ msr 0

The code implements two historic random number generators: the rand() function from BSD libc and the rand() function from the Microsoft C Runtime (MSCVRT.DLL). These generators use the linear congruential generator formula with specific constants. The generators produce a sequence of integers, starting from a seed value, that is not cryptographically secure but can be used for simple tasks. The BSD generator outputs numbers in the range 0 to 2147483647, while the Microsoft generator outputs numbers in the range 0 to 32767.


insertAfter a b (c:cs) | a==c = a : b : cs
                       | otherwise = c : insertAfter a b cs
insertAfter _ _ [] = error "Can't insert"

define a method to insert an element into a singly-linked list after a specified element. The method is then used to insert element C into a list of elements A->B, after element A.


import Prelude hiding (odd)
import Control.Monad (join)

halve :: Int -> Int
halve = (`div` 2)

double :: Int -> Int
double = join (+)

odd :: Int -> Bool
odd = (== 1) . (`mod` 2)

ethiopicmult :: Int -> Int -> Int
ethiopicmult a b =
  sum $
  map snd $
  filter (odd . fst) $
  zip (takeWhile (>= 1) $ iterate halve a) (iterate double b)

main :: IO ()
main = print $ ethiopicmult 17 34 == 17 * 34

The code defines three functions to halve an integer, double an integer, and check if an integer is even. These functions are used to implement Ethiopian multiplication, a method of multiplying integers using only addition, doubling, and halving. The multiplication process involves repeatedly halving the first number and doubling the second number, discarding rows where the first number is even, and summing the remaining values in the second column. The code can also replicate a string n times or raise an integer to the nth power using Ethiopian multiplication.


import Data.List
import Data.Ratio
import Control.Monad
import System.Environment (getArgs)

data Expr = Constant Rational |
    Expr :+ Expr | Expr :- Expr |
    Expr :* Expr | Expr :/ Expr
    deriving (Eq)

ops = [(:+), (:-), (:*), (:/)]

instance Show Expr where
    show (Constant x) = show $ numerator x
      -- In this program, we need only print integers.
    show (a :+ b)     = strexp "+" a b
    show (a :- b)     = strexp "-" a b
    show (a :* b)     = strexp "*" a b
    show (a :/ b)     = strexp "/" a b

strexp :: String -> Expr -> Expr -> String
strexp op a b = "(" ++ show a ++ " " ++ op ++ " " ++ show b ++ ")"

templates :: [[Expr] -> Expr]
templates = do
    op1 <- ops
    op2 <- ops
    op3 <- ops
    [\[a, b, c, d] -> op1 a $ op2 b $ op3 c d,
     \[a, b, c, d] -> op1 (op2 a b) $ op3 c d,
     \[a, b, c, d] -> op1 a $ op2 (op3 b c) d,
     \[a, b, c, d] -> op1 (op2 a $ op3 b c) d,
     \[a, b, c, d] -> op1 (op2 (op3 a b) c) d]

eval :: Expr -> Maybe Rational
eval (Constant c) = Just c
eval (a :+ b)     = liftM2 (+) (eval a) (eval b)
eval (a :- b)     = liftM2 (-) (eval a) (eval b)
eval (a :* b)     = liftM2 (*) (eval a) (eval b)
eval (a :/ b)     = do
    denom <- eval b
    guard $ denom /= 0
    liftM (/ denom) $ eval a

solve :: Rational -> [Rational] -> [Expr]
solve target r4 = filter (maybe False (== target) . eval) $
    liftM2 ($) templates $
    nub $ permutations $ map Constant r4

main = getArgs >>= mapM_ print . solve 24 . map (toEnum . read)

$ runghc 24Player.hs 2 3 8 9
(8 * (9 - (3 * 2)))
(8 * (9 - (2 * 3)))
((9 - (2 * 3)) * 8)
((9 - (3 * 2)) * 8)
((9 - 3) * (8 / 2))
((8 / 2) * (9 - 3))
(8 * ((9 - 3) / 2))
(((9 - 3) / 2) * 8)
((9 - 3) / (2 / 8))
((8 * (9 - 3)) / 2)
(((9 - 3) * 8) / 2)
(8 / (2 / (9 - 3)))
import Control.Applicative
import Data.List
import Text.PrettyPrint

data Expr = C Int | Op String Expr Expr

toDoc (C     x  ) = int x
toDoc (Op op x y) = parens $ toDoc x <+> text op <+> toDoc y

ops :: [(String, Int -> Int -> Int)]
ops = [("+",(+)), ("-",(-)), ("*",(*)), ("/",div)]

solve :: Int -> [Int] -> [Expr]
solve res = filter ((Just res ==) . eval) . genAst
  where
    genAst [x] = [C x]
    genAst xs  = do
      (ys,zs) <- split xs
      let f (Op op _ _) = op `notElem` ["+","*"] || ys <= zs
      filter f $ Op <$> map fst ops <*> genAst ys <*> genAst zs

    eval (C      x  ) = Just x
    eval (Op "/" _ y) | Just 0 <- eval y = Nothing
    eval (Op op  x y) = lookup op ops <*> eval x <*> eval y

select :: Int -> [Int] -> [[Int]]
select 0 _  = [[]]
select n xs = [x:zs | k <- [0..length xs - n]
                    , let (x:ys) = drop k xs
                    , zs <- select (n - 1) ys
                    ]

split :: [Int] -> [([Int],[Int])]
split xs = [(ys, xs \\ ys) | n <- [1..length xs - 1]
                           , ys <- nub . sort $ select n xs
                           ]

main = mapM_ (putStrLn . render . toDoc) $ solve 24 [2,3,8,9]

The code takes four digits as input, either provided by the user or generated randomly, and calculates arithmetic expressions based on the rules of the 24 game. It also displays examples of the solutions it generates.


factorial n = product [1..n]

factorial = product . enumFromTo 1

factorial n = foldl (*) 1 [1..n]

factorials = scanl (*) 1 [1..]

factorial :: Integral -> Integral
factorial 0 = 1
factorial n = n * factorial (n-1)

fac n
    | n >= 0    = go 1 n
    | otherwise = error "Negative factorial!"
        where go acc 0 = acc
              go acc n = go (acc * n) (n - 1)

{-# LANGUAGE PostfixOperators #-}

(!) :: Integer -> Integer
(!) 0 = 1
(!) n = n * (pred n !)

main :: IO ()
main = do
  print (5 !)
  print ((4 !) !)

-- product of [a,a+1..b]
productFromTo a b =
  if a>b then 1
  else if a == b then a
  else productFromTo a c * productFromTo (c+1) b
  where c = (a+b) `div` 2

factorial = productFromTo 1

implement a function to calculate the factorial of a number. This function can be either iterative or recursive. It optionally handles negative number errors. The factorial is the product of all positive integers from 1 to the given number. The code may also include a more efficient method for large numbers.


import Data.List (partition, intersect, nub)
import Control.Monad
import System.Random (StdGen, getStdRandom, randomR)
import Text.Printf

numberOfDigits = 4 :: Int

main = bullsAndCows

bullsAndCows :: IO ()
bullsAndCows = do
    digits <- getStdRandom $ pick numberOfDigits ['1' .. '9']
    putStrLn "Guess away!"
    loop digits

  where loop digits = do
            input <- getLine
            if okay input
              then
                  let (bulls, cows) = score digits input in
                  if bulls == numberOfDigits then
                      putStrLn "You win!"
                  else do
                      printf "%d bulls, %d cows.\n" bulls cows
                      loop digits
              else do
                  putStrLn "Malformed guess; try again."
                  loop digits

        okay :: String -> Bool
        okay input =
            length input == numberOfDigits &&
            input == nub input &&
            all legalchar input
          where legalchar c = '1' <= c && c <= '9'

        score :: String -> String -> (Int, Int)
        score secret guess = (length bulls, cows)
          where (bulls, nonbulls) = partition (uncurry (==)) $
                    zip secret guess
                cows = length $ uncurry intersect $ unzip nonbulls

pick :: Int -> [a] -> StdGen -> ([a], StdGen)
{- Randomly selects items from a list without replacement. -}
pick n l g = f n l g (length l - 1) []
  where  f 0 _ g _   ps = (ps, g)
         f n l g max ps =
             f (n - 1) (left ++ right) g' (max - 1) (picked : ps)
          where (i, g') = randomR (0, max) g
                (left, picked : right) = splitAt i l

generate a unique four-digit number, accept and validate user guesses, calculate and print scores based on matching digits and their positions, and end the program when the user guess matches the generated number.


import System.Random

pairs :: [a] -> [(a,a)]
pairs (x:y:zs) = (x,y):pairs zs
pairs _        = []

gauss mu sigma (r1,r2) =
  mu + sigma * sqrt (-2 * log r1) * cos (2 * pi * r2)

gaussians :: (RandomGen g, Random a, Floating a) => Int -> g -> [a]
gaussians n g = take n $ map (gauss 1.0 0.5) $ pairs $ randoms g

result :: IO [Double]
result = getStdGen >>= \g -> return $ gaussians 1000 g

replicateM 1000 $ normal 1 0.5

import  Data.Random
import Control.Monad

thousandRandomNumbers :: RVar [Double]
thousandRandomNumbers =  replicateM 1000 $ normal 1 0.5

main = do
   x <- sample thousandRandomNumbers
   print x

generate a collection of 1000 normally distributed pseudo-random numbers with a mean of 1.0 and a standard deviation of 0.5, using either built-in libraries or the Data.Random from the random-fu package. The numbers are then printed.


dotp :: Num a => [a] -> [a] -> a
dotp a b | length a == length b = sum (zipWith (*) a b)
         | otherwise = error "Vector sizes must match"

main = print $ dotp [1, 3, -5] [4, -2, -1] -- prints 3

dotProduct :: Num a => [a] -> [a] -> Maybe a
dotProduct a b
  | length a == length b = Just $ dp a b
  | otherwise = Nothing
    where
      dp x y = sum $ zipWith (*) x y

main :: IO ()
main = print n
  where
    Just n = dotProduct [1, 3, -5] [4, -2, -1]

"Implements a function to compute the dot product of two vectors of the same length, by multiplying corresponding terms from each vector and summing the products. The function can handle vectors of arbitrary length and uses the Maybe monad to avoid exceptions and ensure composability."


import System.IO

readLines :: Handle -> IO [String]
readLines h = do
  s <- hGetContents h
  return $ lines s

readWords :: Handle -> IO [String]
readWords h = do
  s <- hGetContents h
  return $ words s

read a text stream either word-by-word or line-by-line until there's no more data. It uses standard functions to convert the file contents into lists of lines or words.


import Data.List
import Text.XML.Light

xmlDOM :: String -> String
xmlDOM txt = showTopElement $ Element
    (unqual "root")
    []
    [ Elem $ Element
      (unqual "element")
      []
      [Text $ CData CDataText txt Nothing]
      Nothing
    ]
    Nothing

*Main> mapM_ (putStrLn.ppContent) $ parseXML (xmlDOM "  Some text  ")
<?xml version="1.0" ?>
<root>
  <element>  Some text  </element>
</root>

Create a simple DOM and serialize it into XML format using the XML.Light module from HackageDB. The XML output includes a root element containing a child element with some text.


import System.Time
       (getClockTime, toCalendarTime, formatCalendarTime)

import System.Locale (defaultTimeLocale)

main :: IO ()
main = do
  ct <- getClockTime
  print ct -- print default format, or
  cal <- toCalendarTime ct
  putStrLn $ formatCalendarTime defaultTimeLocale "%a %b %e %H:%M:%S %Y" cal

import Data.Time (getZonedTime, formatTime, defaultTimeLocale)

main :: IO ()
main = do
  zt <- getZonedTime
  print zt -- print default format, or
  putStrLn $ formatTime defaultTimeLocale "%a %b %e %H:%M:%S %Y" zt

the system time, which can be used for debugging, network information, random number seeds, or program performance. The time is outputted either by a system command or a built-in language function. The units of time are also noted. The code is related to the task of date formatting and uses the time library.


import Data.Char (isAsciiUpper, isDigit, ord)

-------------------------- SEDOLS ------------------------

checkSum :: String -> String
checkSum x =
  case traverse sedolValue x of
    Right xs -> (show . checkSumFromSedolValues) xs
    Left annotated -> annotated

checkSumFromSedolValues :: [Int] -> Int
checkSumFromSedolValues xs =
  rem
    ( 10
        - rem
          ( sum $
              zipWith
                (*)
                [1, 3, 1, 7, 3, 9]
                xs
          )
          10
    )
    10

sedolValue :: Char -> Either String Int
sedolValue c
  | c `elem` "AEIOU" = Left " ← Unexpected vowel."
  | isDigit c = Right (ord c - ord '0')
  | isAsciiUpper c = Right (ord c - ord 'A' + 10)

--------------------------- TEST -------------------------
main :: IO ()
main =
  mapM_
    (putStrLn . ((<>) <*> checkSum))
    [ "710889",
      "B0YBKJ",
      "406566",
      "B0YBLH",
      "228276",
      "B0YBKL",
      "557910",
      "B0YBKR",
      "585284",
      "B0YBKT",
      "BOYBKT", -- Ill formed test case - illegal vowel.
      "B00030"
    ]

The code takes a list of 6-digit SEDOLs as input, calculates the checksum digit for each SEDOL, and appends it to the end of the respective SEDOL. It also validates the input to ensure it contains only valid characters for a SEDOL string.


import Graphics.Rendering.OpenGL.GL
import Graphics.UI.GLUT.Objects
import Graphics.UI.GLUT

setProjection :: IO ()
setProjection = do
  matrixMode $= Projection
  ortho (-1) 1 (-1) 1 0 (-1)

grey1,grey9,red,white :: Color4 GLfloat
grey1 = Color4 0.1 0.1 0.1 1
grey9 = Color4 0.9 0.9 0.9 1
red   = Color4 1   0   0   1
white = Color4 1   1   1   1

setLights :: IO ()
setLights = do
  let l = Light 0
  ambient  l $= grey1
  diffuse  l $= white
  specular l $= white
  position l $= Vertex4 (-4) 4 3 (0 :: GLfloat)
  light    l $= Enabled
  lighting   $= Enabled

setMaterial :: IO ()
setMaterial = do
  materialAmbient   Front $= grey1
  materialDiffuse   Front $= red
  materialSpecular  Front $= grey9
  materialShininess Front $= (32 :: GLfloat)

display :: IO()
display = do
  clear [ColorBuffer]
  renderObject Solid $ Sphere' 0.8 64 64
  swapBuffers

main :: IO()
main = do
  _ <- getArgsAndInitialize
  _ <- createWindow "Sphere"
  clearColor $= Color4 0.0 0.0 0.0 0.0
  setProjection
  setLights
  setMaterial
  displayCallback $= display
  mainLoop
import Data.List (genericLength)

shades = ".:!*oe%#&@"
n = genericLength shades
dot a b = sum $ zipWith (*) a b
normalize x = (/ sqrt (x `dot` x)) <$> x

sphere r k amb light = unlines $
  [ [ if x*x + y*y <= r*r
      then let vec = normalize [x, y, sqrt (r*r-x*x-y*y)]
               b = (light `dot` vec) ** k + amb
               intensity = (1 - b)*(n - 1)
           in shades !! round ((0 `max` intensity) `min` n)
      else ' '
    | y <- map (/2.12) [- 2*r - 0.5 .. 2*r + 0.5]  ]
  | x <- [ - r - 0.5 .. r + 0.5] ]

λ> putStrLn $ sphere 10 4 0.1 (normalize [30,30,-50])

              #%%%%%%%####&&
          eoo*****oooee%%%###&&&
       eo*!!::::!!!**ooee%%%###&&&&
     e*!::......::!!**ooee%%####&&&&&
   %o!::.........::!!**ooee%%###&&&&&&&
  eo!::..........::!!**ooee%%###&&&&&&&&
 %o*!:..........::!!**ooee%%%###&&&&&&&&&
#eo*!::.......:::!!**ooeee%%####&&&&&&&&&&
%eo*!!:::::::::!!***ooeee%%####&&&&&&&&&&&
%eeo**!!!!!!!!****ooeee%%%####&&&&&&&&&&&&
#%eeooo*******ooooeee%%%%####&&&&&&&&&&&&&
##%%eeeoooooooeeeee%%%%####&&&&&&&&&&&&&&&
&###%%%%eeeeee%%%%%%######&&&&&&&&&&&&&&&#
 &&####%%%%%%%%########&&&&&&&&&&&&&&&&&&
  &&&##############&&&&&&&&&&&&&&&&&&&&&
   &&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&#
     &&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
       &&&&&&&&&&&&&&&&&&&&&&&&&&&&
          &&&&&&&&&&&&&&&&&&&&&&
              &&&&&&&&&&&&&#

"Generates a graphical or ASCII art representation of a sphere, with either static or rotational projection."


import Data.Array

ordSuffs :: Array Integer String
ordSuffs = listArray (0,9) ["th", "st", "nd", "rd", "th",
                            "th", "th", "th", "th", "th"]

ordSuff :: Integer -> String
ordSuff n = show n ++ suff n
  where suff m | (m `rem` 100) >= 11 && (m `rem` 100) <= 13 = "th"
               | otherwise          = ordSuffs ! (m `rem` 10)

printOrdSuffs :: [Integer] -> IO ()
printOrdSuffs = putStrLn . unwords . map ordSuff

main :: IO ()
main = do
  printOrdSuffs [   0..  25]
  printOrdSuffs [ 250.. 265]
  printOrdSuffs [1000..1025]

The code defines a function that takes an integer input greater than or equal to zero and returns a string representation of the number with an ordinal suffix. The function is tested with ranges 0 to 25, 250 to 265, and 1000 to 1025. The use of apostrophes in the output is optional.


stripChars :: String -> String -> String
stripChars = filter . flip notElem

Testing in GHCI:
> stripChars "aei" "She was a soul stripper. She took my heart!"
"Sh ws  soul strppr. Sh took my hrt!"

The code defines a function that takes two strings as input, strips the characters from the first string that are present in the second string, and returns the modified string. The function is designed to be partially applied with the characters to be stripped.


fizz :: (Integral a, Show a) => a -> [(a, String)] -> String
fizz a xs
    | null result = show a
    | otherwise   = result
    where result = concatMap (fizz' a) xs
          fizz' a (factor, str)
              | a `mod` factor == 0 = str
              | otherwise           = ""

main = do
    line <- getLine
    let n = read line
    contents <- getContents
    let multiples = map (convert . words) $ lines contents
    mapM_ (\ x -> putStrLn $ fizz x multiples) [1..n]
    where convert [x, y] = (read x, y)

type Rule = (Int, String)

----------------- FIZZETC (USING RULE SET) ---------------

fizzEtc :: [(Int, String)] -> [String]
fizzEtc rules = foldr nextLine [] [1 ..]
  where
    nextLine x a
      | null noise = show x : a
      | otherwise = noise : a
      where
        noise = foldl reWrite [] rules
        reWrite s (m, k)
          | 0 == rem x m = s <> k
          | otherwise = s

------------------- TEST OF SAMPLE RULES -----------------
fizzTest :: [String]
fizzTest = fizzEtc [(3, "Fizz"), (5, "Buzz"), (7, "Baxx")]

main :: IO ()
main = mapM_ putStrLn $ take 20 fizzTest

is a generalized FizzBuzz program that accepts a maximum number and a list of factors with their corresponding words from the user. It prints numbers from 1 to the maximum number, replacing multiples of the given factors with their associated words. If a number is a multiple of more than one factor, it prints all the corresponding words in ascending order of their factors.


Prelude> let f = (++" World!")
Prelude> f "Hello"

Creates a string variable with a specific text value, prepends another string literal to it, and displays the content of the variable. If possible, the operation is performed without referring to the variable twice in one expression.


import Data.List
import Graphics.Gnuplot.Simple

-- diamonds
-- pl = [[0,1],[1,0]]

pl = [[0,0],[0,1]]
r_90 = [[0,1],[-1,0]]

ip :: [Int] -> [Int] -> Int
ip xs = sum . zipWith (*) xs
matmul xss yss = map (\xs -> map (ip xs ). transpose $ yss) xss

vmoot xs = (xs++).map (zipWith (+) lxs). flip matmul r_90.
          map (flip (zipWith (-)) lxs) .reverse . init $ xs
   where lxs = last xs

dragoncurve = iterate vmoot pl

plotPath [] . map (\[x,y] -> (x,y)) $ dragoncurve!!13

x 0 = ""
x n = (x$n-1)++" +"++(y$n-1)++" f +"
y 0 = ""
y n = " - f"++(x$n-1)++" -"++(y$n-1)

dragon n =
	concat ["0 setlinewidth 300 400 moveto",
		"/f{2 0 rlineto}def/+{90 rotate}def/-{-90 rotate}def\n",
		"f", x n, " stroke showpage"]

main = putStrLn $ dragon 14

The code generates a dragon curve fractal, either displaying it directly or writing it to an image file. It uses various algorithms to create the fractal, including recursive and iterative methods, as well as successive approximation and Lindenmayer system of expansions. The code can also calculate the absolute direction and X,Y coordinates of a point, and test whether a given point or segment is on the curve. The curve can be drawn to a desired expansion level and the curl direction can be a parameter. The code uses the gnuplot interface module for plotting and can output a postscript.