Jason Dew

[Haskell] Pseudo Genetic Programming

2009-02-02T19:06:57-08:00

This code probably needs cleanup and definitely could use a performance boost. I wanted to parallelize some parts of it but didn't have any luck...

It takes an image and generates an image of random rectangles with the same dimensions. Then it mutates that image to see if the mutation is a closer match to the target image than the original random image. Rinse and repeat.

Blog post with some references: http://jasondew.com/2009/02/02/pseudo-genetic-programming-in-haskell

import Prelude hiding (lookup)
import System.Random
import Control.Monad
import Graphics.GD
import Foreign.C.Types
import Data.Bits
import Data.Map hiding (map)
import Data.Time
import Text.Printf
 
type Rectangle = (Point, Point, Color)
type DNA = [Rectangle]
 
numberOfObjects :: Int
numberOfObjects = 5
 
numberOfAdditions :: Int
numberOfAdditions = 1
 
additionProbability :: Int
additionProbability = 1
 
mutationProbability :: Int
mutationProbability = 10
 
numberOfIterations :: Int
numberOfIterations = 1000000
 
snapshotEvery :: Int
snapshotEvery = 10
 
jpegQuality :: Int
jpegQuality = 90
 
targetPath :: String
targetPath = "monalisa.jpg"
 
-- =======================================================================================================================
 
targetImage :: IO Image
targetImage = loadJpegFile targetPath
 
targetPixelColors :: Int -> Int -> IO [(Point, Color)]
targetPixelColors width height = do image <- targetImage
                                    mapM (\point -> mapColor image point) [(x, y) | x <- [1..width], y <- [1..height]]
                                 where mapColor image point = do color <- getPixel point image
                                                                 return (point, color)
 
randomNumberGenerator = randomR (0, 100)
randomRGBGenerator = randomR (0, 255)
randomAlphaGenerator = randomR (0, 127)
 
randomColor :: IO Color
randomColor = do red <- getStdRandom randomRGBGenerator
                 green <- getStdRandom randomRGBGenerator
                 blue <- getStdRandom randomRGBGenerator
                 alpha <- getStdRandom randomAlphaGenerator
                 return $ rgba red green blue alpha
 
alpha :: Num a => Color -> a
alpha color = fromIntegral $ color `shiftR` 24
 
red :: Num a => Color -> a
red color = fromIntegral $ (color .&. 16711680) `shiftR` 16
 
green :: Num a => Color -> a
green color = fromIntegral $ (color .&. 65280) `shiftR` 8
 
blue :: Num a => Color -> a
blue color = fromIntegral $ color .&. 255
 
randomPoint :: Int -> Int -> IO Point
randomPoint maxX maxY = do x <- getStdRandom $ randomR (0, maxX)
                           y <- getStdRandom $ randomR (0, maxY)
                           return (x, y)
 
randomRectangle :: Int -> Int -> IO Rectangle
randomRectangle maxX maxY = do start <- randomPoint maxX maxY
                               end <- randomPoint maxX maxY
                               color <- randomColor
                               return (start, end, color)
 
drawRectangle :: Rectangle -> Image -> IO ()
drawRectangle (start, end, color) image = drawFilledRectangle start end color image
 
initialDNA :: Int -> Int -> Int -> IO DNA
initialDNA objects maxX maxY = sequence [randomRectangle maxX maxY | _ <- [1..objects]]
 
drawDNAImage :: Int -> Int -> IO DNA -> IO Image
drawDNAImage width height ioDNA = do image <- newImage (width, height)
                                     dna <- ioDNA
                                     mapM_ (\rectangle -> drawRectangle rectangle image) dna
                                     return image
 
mutatedValue :: Int -> Int -> IO Int
mutatedValue original max = do offset <- getStdRandom $ randomR (0, max)
                               return $ (original + offset) `mod` max
 
maybeMutateValue :: Int -> Int -> IO Int
maybeMutateValue original max = do randomNumber <- getStdRandom randomNumberGenerator
                                   case randomNumber < mutationProbability of
                                     True -> mutatedValue original max
                                     False -> return original
 
maybeMutatePoint :: Point -> Int -> Int -> IO Point
maybeMutatePoint (x, y) maxX maxY = do newX <- maybeMutateValue x maxX
                                       newY <- maybeMutateValue y maxY
                                       return (newX, newY)
 
maybeMutateColor :: Color -> IO Color
maybeMutateColor original = do possiblyMutatedRed <- maybeMutateValue (red original) 255
                               possiblyMutatedGreen <- maybeMutateValue (green original) 255
                               possiblyMutatedBlue <- maybeMutateValue (blue original) 255
                               possiblyMutatedAlpha <- maybeMutateValue (alpha original) 127
                               return $ rgba possiblyMutatedRed possiblyMutatedGreen possiblyMutatedBlue possiblyMutatedAlpha
 
maybeMutateRectangle :: Rectangle -> Int -> Int -> IO Rectangle
maybeMutateRectangle rectangle maxX maxY = do randomNumber <- getStdRandom randomNumberGenerator
                                              case randomNumber < mutationProbability of
                                                True -> mutateRectangle rectangle maxX maxY
                                                False -> return rectangle
 
mutateRectangle :: Rectangle -> Int -> Int -> IO Rectangle
mutateRectangle (start, end, color) maxX maxY = do possiblyMutatedStart <- maybeMutatePoint start maxX maxY
                                                   possiblyMutatedEnd <- maybeMutatePoint end maxX maxY
                                                   possiblyMutatedColor <- maybeMutateColor color
                                                   return (possiblyMutatedStart, possiblyMutatedEnd, possiblyMutatedColor)
 
maybeNewRectangles :: Int -> Int -> IO [Rectangle]
maybeNewRectangles maxX maxY = do randomNumber <- getStdRandom randomNumberGenerator
                                  case randomNumber < additionProbability of
                                    True -> mapM (\i -> randomRectangle maxX maxY) [1..numberOfAdditions]
                                    False -> return []
mutateDNA :: DNA -> Int -> Int -> IO DNA
mutateDNA (rectangle:rectangles) maxX maxY = do possiblyMutatedRectangle <- maybeMutateRectangle rectangle maxX maxY
                                                possiblyMutatedRectangles <- mutateDNA rectangles maxX maxY
                                                possiblyNewRectangles <- maybeNewRectangles maxX maxY
                                                return $ (possiblyMutatedRectangle : possiblyMutatedRectangles) ++ possiblyNewRectangles
mutateDNA _ _ _ = return []
 
colorDifference :: Color -> Color -> Float
colorDifference color1 color2 = let redDelta = (red color1) - (red color2)
                                    greenDelta = (green color1) - (green color2)
                                    blueDelta = (blue color1) - (blue color2)
                                in sum $ map (** 2.0) [redDelta, greenDelta, blueDelta]
 
comparePixel :: Point -> Map Point Color -> Image -> IO Float
comparePixel point target image = do case lookup point target of
                                       Just color -> do candidateColor <- getPixel point image
                                                        return $ colorDifference color candidateColor
                                       Nothing -> return 0.0
 
fitness :: Map Point Color -> Image -> Int -> Int -> IO Float
fitness target image width height = do deltas <- mapM (\point -> comparePixel point target image)
                                                      [(x, y) | x <- [1..width], y <- [1..height]]
                                       return $ sum deltas
 
printStatus :: Int -> Float -> [Float] -> Int -> IO ()
printStatus iteration fit previousFits objects = do currentTime <- getCurrentTime
                                                    printf "%30s: iteration: %8d, objects: %5d, fit: %14.0f, fit delta: %12.0f, percent improvement: %5.1f%%\n"
                                                           (show currentTime) iteration objects fit delta percentImprovement
 
                                                 where findLastSeenFit [] = 0.0
                                                       findLastSeenFit fits = fits !! (snapshotEvery `mod` (length fits))
 
                                                       lastSeenFit = findLastSeenFit previousFits
                                                       delta = lastSeenFit - fit
                                                       percentImprovement = 100.0 * (delta / lastSeenFit)
 
nextGeneration :: Map Point Color -> Int -> Int -> DNA -> Float -> Int -> IO (DNA, Float)
nextGeneration target width height currentDNA currentFit iteration =
  do case iteration `mod` snapshotEvery of
       0 -> do image <- drawDNAImage width height $ return currentDNA
                       saveJpegFile jpegQuality ("iteration" ++ (show iteration) ++ ".jpg") image
       otherwise -> return ()
 
     mutatedDNA <- mutateDNA currentDNA width height
     mutatedImage <- drawDNAImage width height $ return mutatedDNA
     mutatedFit <- fitness target mutatedImage width height
 
     case (mutatedFit < currentFit) of
       True -> return (mutatedDNA, mutatedFit)
       False -> return (currentDNA, currentFit)
 
simulationStep :: Map Point Color -> Int -> Int -> DNA -> Int -> Int -> [Float] -> IO [Float]
simulationStep target width height currentDNA iteration totalIterations fits@(currentFit:_)
  | iteration == totalIterations = return fits
  | otherwise = do (nextDNA, nextFit) <- nextGeneration target width height currentDNA currentFit iteration
 
                                      case iteration `mod` snapshotEvery of
                                        0 -> printStatus iteration currentFit fits $ length currentDNA
                                        otherwise -> return ()
 
                                      simulationStep target width height nextDNA (iteration + 1) totalIterations (nextFit:fits)
 
runSimulation :: Map Point Color -> Int -> Int -> DNA -> Int -> IO [Float]
runSimulation target width height ivDNA iterations = simulationStep target width height ivDNA 0 iterations [1e12]
 
main :: IO ()
main = do startTime <- getCurrentTime
          putStrLn $ (show startTime) ++ ": processing started; initial objects = " ++ (show numberOfObjects) ++
                     ", increment = " ++ (show numberOfAdditions) ++
                     ", increment probability = " ++ (show additionProbability) ++
                     ", mutation probability = " ++ (show mutationProbability)
 
          (width, height) <- withImage targetImage imageSize
          target <- targetPixelColors width height
          dna <- initialDNA numberOfObjects width height
          fits <- runSimulation (fromList target) width height dna numberOfIterations
          putStrLn $ show fits

[Ruby] On Think this needs a loop

2008-09-06T20:21:34-07:00

How about this?

## helper
def extract source, number, attribute
  (0..(number-1)).inject(Array.new) do |result, index|
    result << source[index][attribute]
  end
end

## controller 
feed = RssParser.run("http://ws.audioscrobbler.com/1.0/user/me/recenttracks.rss")
@songs = extract feed[:items], 3, :title
@links = extract feed[:items], 3, :link

## view
<ul id="lastfm_update_list">
	<% @songs.each_with_index do |song, count| %>			
		<li><%= link_to song, @links[count] %></li>
	<% end %>
</ul>

[Ruby] On Dashboard

2008-07-21T22:59:27-07:00

I would consider moving the cases into their respective helpers and calling them that way:

So you would define a method in JobHelper, CandidateHelper, and CommentHelper called activity_message. Hope this helps,

module DashboardHelper

  def activity_message_for object
    "#{object.class.name.classify}Helper".constantize.send(:activity_message, object)
  end

end

[Ruby] On Enumerable#cluster

2008-07-18T23:36:20-07:00

If you don't need the order preserved and a hash is sufficient... If you want to keep the ordering, replace with OrderedHash in ActiveSupport (or Ruby 1.9). cluster_arrayed an implementation that returns an array of arrays.

module Enumerable
  def cluster
    inject(Hash.new) do |all, one|
      all[one] = (all[one] || 0) + 1
      all
    end
  end

  def cluster_arrayed
    cluster.inject(Array.new) do |all, (key, count)|
      all << [key] * count
    end
  end
end

[Ruby] On cleaner way to limit results from xml

2008-07-15T00:36:49-07:00

Stream parsing might be something to look into -- http://www.germane-software.com/software/rexml/docs/tutorial.html#id2248814

[Ruby] On Query String to Hash

2008-07-10T23:20:05-07:00

Seems like this should do the job and a little cleaner.

Hash[*uri.query.split("&").map {|part| part.split("=") }.flatten]

[Ruby] On Rubyize this : 5th edition

2008-01-03T17:24:23-08:00

i purposely wrote this without looking at the refactorings... funny how close it still is but it's a bit different. a little more verbose imo but extensible. the only issue i have with it is that you are limited to one a single delimiter.

class Highlighter

  def initialize(keywords, prefix='*', suffix='*', delimiter=' ')
    @keywords, @prefix, @suffix, @delimiter = keywords, prefix, suffix, delimiter
  end

  def highlight(text)
    text.split(@delimiter).collect do |word|
      @keywords.include?(word) ? highlight_word(word) : word
    end.join(@delimiter)
  end

  private

  def highlight_word(word)
    @prefix + word + @suffix
  end

end

highlighter = Highlighter.new %w(important monkey dancing)

text = "there are some very important monkeys dancing the most important of all dances in monkey land"
highlighted_text = highlighter.highlight(text)

puts "ORIGINAL   : #{text}"
puts "HIGHLIGHTED: #{highlighted_text}"

[Ruby] On Creating an alphabetic for search

2007-12-30T20:45:33-08:00

I did leave out a piece (the html << in front of link_to). What kind of values are you giving to params[:search]?

[Ruby] On Creating an alphabetic for search

2007-12-30T19:22:05-08:00

Apologies, I wrote this code without testing it ... Please see the updated helper code and rate if you found it useful. Thanks!

## helper

LETTERS = ('A'..'Z').entries + ['#']

def navigation_links(current_letter)
  returning [] do |html|
    LETTERS.each do |letter|
      if letter == current_letter
        html << content_tag( :span, letter, :class => 'current' )
      else
        html << link_to( letter, :controller => 'controller', :search => letter )
      end
    end
  end.join
end

[Ruby] On Refactor my blog item helper

2007-12-20T02:04:00-08:00

very true :-)

[Ruby] On Refactor my blog item helper

2007-12-19T18:46:46-08:00

I didn't consider sorting in the original refactoring so here's the updated version. Hope it helps,

## Helper

def list_for_blogentries(user)
  blogentries_by_day = user.blogentries.group_by {|entry| entry.created_at.to_date }
  blogentries_sorted_by_day = blogentries_by_day.sort_by {|(date, entries)| date }.reverse
  
  returning "" do |html|
    blogentries_sorted_by_day.each do |date, entries|
      html << date.to_s
      entries.each {|entry| html << link_for_entry(entry) }
    end
  end
end

[Ruby] On Refactor my blog item helper

2007-12-19T13:28:26-08:00

See if this works for you. I would also consider moving the user.blogentries.group_by code into the association proxy -- so you would call user.blogentries.by_day instead. Check out "Association extensions" here: http://api.rubyonrails.org/classes/ActiveRecord/Associations/ClassMethods.html for more information.

## Helper

def list_for_blogentries(user)
  blogentries_by_day = user.blogentries.group_by {|entry| entry.created_at.to_date }
  
  returning "" do |html|
    blogentries_by_day.each do |date, entries|
      html << date.to_s
      entries.each {|entry| html << link_for_entry(entry) }
    end
  end
end

[Ruby] On Creating an alphabetic for search

2007-12-17T00:25:06-08:00

I don't really like having to define a variable inside your view, so I would move the code into a helper.

## Helper

LETTERS = ('A'..'Z').entries + ['#']

def navigation_links(current_letter)
  LETTERS.each do |letter|
    if letter == current_letter
      content_tag :span, letter, :class => 'current'
    else
      link_to letter, :controller => 'controller', :search => letter
    end
  end
end

## View [html_rails]

<div class="pagination">
  <%= navigation_links params[:search] %>
</div>

[Ruby] On split_in_groups instead of in_groups_of

2007-11-28T17:23:16-08:00

here's my first shot at it

##code [ruby]

class Array

  def in_uniform_groups_of(group_count)
    answer = Array.new
    index = 0

    self.class.uniform_partition_sizes(self.size, group_count).each do |size|
      answer << self.slice( index, size )
      index += size
    end

    answer
  end

  def self.uniform_partition_sizes(size, partitions)
    answer = Array.new( partitions, size / partitions )

    index = 0
    total = (size / partitions) * partitions

    while total < size
      answer[index] += 1
      index = (index + 1) % partitions
      total += 1
    end

    answer
  end

end

puts (1..9).to_a.in_uniform_groups_of(4).inspect
puts (1..10).to_a.in_uniform_groups_of(4).inspect

[Ruby] On Simple Text Replacement

2007-11-16T13:16:13-08:00

I agree with Scott about making the first argument to gsub! a string rather than a hash and I also agree with not using send (or eval). However, I also think that you should DRY up the hash by removing the curly braces. So, to add onto Scott's code:

About the common courtesies, I would say rate them and leave comments for the refactorers.

def replace_keywords(keywords, text)
  keywords.each do |keyword, replacement|
    text.gsub! "\{#{keyword}\}", replacement
  end

  text
end

keywords = { 'city' => 'Chicago', 'state' => 'Illinois' }
text = "Welcome to {city}, {state}"

puts replace_keywords(keywords, text)

[Ruby] On Simple Text Replacement

2007-11-16T03:18:31-08:00

How about this?

def replace_keywords(keywords, text)
  keywords.each do |keyword, replacement|
    text.send( 'gsub!', "\{#{keyword}\}", "#{replacement}" )
  end

  text
end

keywords = { 'city' => 'Chicago', 'state' => 'Illinois' }
text = "Welcome to {city}, {state}"

puts replace_keywords(keywords, text)

[Ruby] On Circular Cipher

2007-11-10T02:06:37-08:00

The original and most of these refactorings fail if the key length is less than the message length.

[Ruby] On Circular Cipher

2007-11-07T03:46:40-08:00

this code will be much cleaner in Ruby 1.9 when we get external iterators.... but, i formed the code into a class, cleaned up the math a bit, and made the cipher reuse the key if the string to be encoded/decoded is longer than the key. i also added a very simple spec (using RSpec)

## class [ruby]

class Cipher

        Offset = ?\  # ascii value of a space
        Range = ?z - ?\ # difference between ascii values for z and space

        def initialize(key)
                @key = key
                @key_length = key.size
        end

        def encode( clear_text )
                cipher_text = String.new
                index = 0

                clear_text.each_byte do |byte|
                        cipher_text << (byte + @key[index % @key_length] - 2*Offset) % Range + Offset
                        index += 1
                end

                cipher_text
        end

        def decode( cipher_text )
                clear_text = String.new
                index = 0;

                cipher_text.each_byte do |byte|
                        clear_text << (byte - @key[index % @key_length] + Range) % Range + Offset
                        index += 1
                end

                clear_text
        end

end

## spec [ruby]

require 'cipher'

describe Cipher, "with a sufficient key size" do

        before do
                @cipher = Cipher.new( "s7eOhg2fqgPRWXtp303B67551G5zpEyHe78q5NR5eWKP9eq9fk54D23" )
        end


        it "should correctly encode a string" do
                @cipher.encode( "I wonder if this code can be better." ).should == 'B7bD\Qw^qV<RQFci3s(,!7xv%Gwep-dB_"0%'

        end

        it "should correctly decode a string" do
                @cipher.decode( 'B7bD\Qw^qV<RQFci3s(,!7xv%Gwep-dB_"0%' ).should == "I wonder if this code can be better."
        end

end

describe Cipher, "without a sufficient key size" do

        before do
                @cipher = Cipher.new( "s3EHqP9f23" )
        end


        it "should correctly encode a string" do
                @cipher.encode( "I wonder if this code can be better." ).should == "B3B=e:$^2\"_3?6`I9O'w^3./eP!Q2u^-?3i^"

        end

        it "should correctly decode a string" do
                @cipher.decode( "B3B=e:$^2\"_3?6`I9O'w^3./eP!Q2u^-?3i^" ).should == "I wonder if this code can be better."
        end

end

[Ruby] On Combining add/remove links

2007-10-16T23:25:02-07:00

I don't see where you use the argument to these functions.... Anyway, here's my shot at refactoring

  def add_associated_link(model_name, label = "Add another")
    link_to_function label do |page|
    	page.insert_html :bottom, model_name.pluralize, :partial => model_name, :object => model_name.camelize.constantize.new
    end
  end
  
  def remove_associated_link(model_name, label = "Remove")
    link_to_function label {|page| page["#{model_name}_#{params[:index]}"].remove }
  end