Example of transformation on Parnas's KWIC program (original transformation by W. Griswold)

module Input where
import PreludeExt
 
 
putfile linelist = putfile_aux linelist emptylist
 
    where
 
      insline [] linestorage = linestorage
      insline line linestorage = line : linestorage
 
      putfile_aux [] accu = accu
      putfile_aux (e:r) accu = putfile_aux r (insline e accu)

module Shifter where
import PreludeExt
import Input 
import Array
 
 
default_value = (0,0) 
 
cssetup::[[String]]-> (Int , Int, Array Int (Int,Int))
cssetup linestorage =
    cssetup_aux 0 0 circ_index_0
 
    where 
      circ_index_0 = array (0,numcslines) [(i, default_value) | i <- [0..numcslines]]
 
      numlines = length linestorage
 
      numcslines = allwords linestorage 
          where
            allwords ls = allwords_aux ls 0
                where  
                  allwords_aux [] sum = sum
                  allwords_aux (e:r) sum = allwords_aux r (sum + length e)
 
      cssetup_aux cslineno lineno circ_index= 
          if lineno /= numlines
          then 
              let aux2 cslineno_arg wordno circ_index = 
	              if wordno /= numwords
	              then  aux2 (cslineno_arg + 1) (wordno + 1) (circ_index//[(cslineno_arg,(lineno, wordno))])
		      else (cslineno_arg, circ_index)
 
                          where  
                            numwords = length (nth linestorage lineno)        
	      in 
                let (cslineno', circ_index') = aux2 cslineno 0 circ_index
	        in
	          cssetup_aux cslineno' (lineno + 1) circ_index'
          else (cslineno, lineno, circ_index)

module Alphabet where
import PreludeExt
import Input 
import Shifter 
import Array
 
 
alph:: Array Int (Int,Int) -> [[String]] -> Array Int (Int,Int)
alph circ_index line_storage = qalph 0 (numitems - 1) (alph_aux 0 alph_index0 circ_index)
 
  where
 
    numitems = snd (bounds circ_index) 
 
    alph_index0 = array (0,numitems) [(i,default_value) | i <- [0..numitems]]
 
    alph_aux i aindex cindex = 
	if i /= numitems
	then alph_aux (i+1) (aindex//[(i,(cindex!i))]) cindex
	else aindex
 
 
    csline_inf shift1 shift2 ls  = inf_aux 0
          where
 
            csword (lno,fwno) wordno ls =
	          nth (nth ls lno) (mod (fwno + wordno) (length (nth ls lno)))
 
            cswords shift ls =
	          length (nth ls (fst shift)) 
 
            lasti  = min (cswords shift1 ls) (cswords shift2 ls)
 
            inf_aux i = 
                let maxed_ = (i == lasti) 
                    cword1 = csword shift1 i ls
                    cword2 = csword shift2 i ls
                in 
	          if (maxed_ || (not (cword1 == cword2)))
	          then 
	              if maxed_ 
                      then lasti <= (cswords shift2 ls)
                      else cword1 <= cword2
	          else inf_aux (i+1)
 
 
    swap_indices::Array Int (Int,Int) -> Int -> Int -> Array Int (Int,Int)
    swap_indices vec i j = 
          let tempi = vec!i 
              tempj = vec!j
          in 
            vec // [(i,tempj),(j,tempi)] 
 
 
    qsplit start end split alph_index =
            let (l,aind) = qsplit_aux (start+1) end start (swap_indices alph_index start split) 
                aind2    = swap_indices aind split (l-1)
            in (aind2, l-1)
 
                where
 
                  qsplit_aux low high split alph_index  =
	              if not (low > high)
	              then 
	                  if csline_inf (alph_index!low) (alph_index!split) line_storage
	                  then qsplit_aux (low+1) high split alph_index
	                  else qsplit_aux low (high-1) split (swap_indices alph_index low high)
	              else (low, alph_index)
 
 
    qalph start end alph_index= 
            if start < end
            then
	        let 
                    split = start 
	            (aindex,middle) = qsplit start end split alph_index
	            aindex' = qalph start (middle-1) aindex 
                in
	          qalph (middle+1) end aindex'
            else alph_index

module Output where
import PreludeExt
import Input 
import Alphabet
import Array
 
string_of_list l = foldl (\ a b -> a ++ b) "" l
 
 
allalphcslines line_storage alph_index = allalphcslines_aux 0 ""
    where
      allalphcslines_aux i accu =
          if i /= numcslines
          then let s = string_of_list (csline (alph_index!i) line_storage)
               in allalphcslines_aux (i+1) (accu ++ "\n" ++ s)
          else accu
              where
                numcslines = snd (Array.bounds alph_index)             
 
      csline (lno,fwno) ls =  reverse (csline_aux [] 0)
            where
              csline_aux revcs i =
	          if (i /= wrdcnt)
	          then csline_aux ((nth (nth ls lno) (mod (i + fwno)  wrdcnt)) : revcs) (i+1)
	          else revcs
 
              wrdcnt = length (nth ls lno)

module Main where
import PreludeExt
import Input 
import Shifter 
import Alphabet 
import Output
 
l = putfile [ ["a","b","c","d"] , ["one"] , ["hey", "this" , "is" , "different"] , ["a","b","c","d"] ] 
 
(a,b,s) = cssetup l 
 
s' = alph s l 
 
res = allalphcslines l s' 
 
main = putStrLn res

module LineStorage where
 import PreludeExt
 
 
 allwords ls = allwords_aux ls 0
     where  
       allwords_aux [] sum = sum
       allwords_aux (e:r) sum = allwords_aux r (sum + length e)
 
 line ls lno = nth ls lno
 
 emptyStorage = emptylist
 
 ls_words nth linestorage lineno = length (nth linestorage lineno)
 
 ls_lines linestorage = length linestorage
 
 insline [] linestorage = linestorage
 insline line linestorage = line : linestorage

 module Input where
import PreludeExt
import LineStorage (insline,emptyStorage)
 
 
putfile linelist = putfile_aux linelist emptyStorage
 
    where
 
 
      putfile_aux [] accu = accu
      putfile_aux (e:r) accu = putfile_aux r (insline e accu)

module Shifter where
import PreludeExt
import Input 
import Array
import LineStorage (ls_lines,ls_words,line,allwords)
 
 
printable_csline (lno,fwno) ls =  reverse (csline_aux [] 0)
      where
        csline_aux revcs i =
	          if (i /= wrdcnt)
	          then csline_aux ((nth (line ls lno) (mod (i + fwno) wrdcnt)) : revcs) (i+1)
	          else revcs
 
        wrdcnt = length (line ls lno) 
 
csline cindex i = cindex ! i
 
cslines circ_index = snd (bounds circ_index)
 
csline_inf shift1 shift2 ls  = inf_aux 0
      where
 
 
 
        lasti  = min (cswords shift1 ls) (cswords shift2 ls)
 
        inf_aux i = 
            let maxed_ = (i == lasti) 
                cword1 = csword shift1 i ls
                cword2 = csword shift2 i ls
            in 
	          if (maxed_ || (not (cword1 == cword2)))
	          then 
	              if maxed_ 
                  then lasti <= (cswords shift2 ls)
                  else cword1 <= cword2
	          else inf_aux (i+1)
 
cswords shift ls =
	          length (line ls (fst shift)) 
 
 
csword (lno,fwno) wordno ls =
	          (nth (line ls lno)
                (mod (fwno + wordno) (length (line ls lno))))
 
 
 
default_value = (0,0) 
 
cssetup::[[String]]-> (Int , Int, Array Int (Int,Int))
cssetup linestorage =
    cssetup_aux 0 0 circ_index_0
 
    where 
      circ_index_0 = array (0,numcslines) [(i, default_value) | i <- [0..numcslines]]
 
      numlines = (ls_lines linestorage)
 
      numcslines = allwords linestorage 
 
 
      cssetup_aux cslineno lineno circ_index= 
          if lineno /= numlines
          then 
              let aux2 cslineno_arg wordno circ_index = 
	              if wordno /= numwords
	              then  aux2 (cslineno_arg + 1) (wordno + 1) (circ_index//[(cslineno_arg,(lineno, wordno))])
		      else (cslineno_arg, circ_index)
 
                          where  
                            numwords = (ls_words nth linestorage lineno)        
 
	      in 
                let (cslineno', circ_index') = aux2 cslineno 0 circ_index
	        in
	          cssetup_aux cslineno' (lineno + 1) circ_index'
          else (cslineno, lineno, circ_index)

module Alphabet where
import PreludeExt
import Input 
import Shifter 
import Array
 
 
alphcslines alph_index = snd (Array.bounds alph_index)
 
alphcsline (!) alph_index i = alph_index ! i
 
alph:: Array Int (Int,Int) -> [[String]] -> Array Int (Int,Int)
alph circ_index line_storage = qalph 0 (numitems - 1) (alph_aux 0 alph_index0 circ_index)
 
  where
 
    numitems = (cslines circ_index) 
 
 
    alph_index0 = array (0,numitems) [(i,default_value) | i <- [0..numitems]]
 
    alph_aux i aindex cindex = 
	if i /= numitems
	then alph_aux (i+1) (aindex//[(i,((csline cindex i)))]) cindex
	else aindex
 
 
 
 
 
    swap_indices::Array Int (Int,Int) -> Int -> Int -> Array Int (Int,Int)
    swap_indices vec i j = 
          let tempi = vec!i 
              tempj = vec!j
          in 
            vec // [(i,tempj),(j,tempi)] 
 
 
    qsplit start end split alph_index =
            let (l,aind) = qsplit_aux (start+1) end start (swap_indices alph_index start split) 
                aind2    = swap_indices aind split (l-1)
            in (aind2, l-1)
 
                where
 
                  qsplit_aux low high split alph_index  =
	              if not (low > high)
	              then 
	                  if csline_inf (alph_index!low) (alph_index!split) line_storage
	                  then qsplit_aux (low+1) high split alph_index
	                  else qsplit_aux low (high-1) split (swap_indices alph_index low high)
	              else (low, alph_index)
 
 
    qalph start end alph_index= 
            if start < end
            then
	        let 
                    split = start 
	            (aindex,middle) = qsplit start end split alph_index
	            aindex' = qalph start (middle-1) aindex 
                in
	          qalph (middle+1) end aindex'
            else alph_index

module Output where
import PreludeExt
import Input 
import Alphabet hiding ()
import Array
import Shifter (printable_csline)
 
string_of_list l = foldl (\ a b -> a ++ b) "" l
 
 
allalphcslines line_storage alph_index = allalphcslines_aux 0 ""
    where
      allalphcslines_aux i accu =
          if i /= numcslines
          then let s = string_of_list (printable_csline ((alphcsline (!) alph_index i)) line_storage)
 
               in allalphcslines_aux (i+1) (accu ++ "\n" ++ s)
          else accu
              where
                numcslines = (alphcslines alph_index)

module Main where
import PreludeExt
import Input 
import Shifter 
import Alphabet 
import Output
 
l = putfile [ ["a","b","c","d"] , ["one"] , ["hey", "this" , "is" , "different"] , ["a","b","c","d"] ] 
 
(a,b,s) = cssetup l 
 
s' = alph s l 
 
res = allalphcslines l s' 
 
main = putStrLn res