Hatupist - teemme ohjelman kirjoitusnopeusharjoitteluun

[snifi]

Aloitan tämän viestiketjun tavoitteena tulevien kuukausien aikana yhdessä rakentaa ohjelma, jolla harjoitella kirjoitusnopeutta kymmensormijärjestelmällä (tai miksei muullakin -järjestelmällä). Olen ajatellut, että ohjelman ulkoasu voisi näyttää vaikkapa jotakuinkin tämänlaiselta:



Itse tulen käyttämään Haskell-ohjelmointikieltä ja Gtk2hs-käyttöliittymää.

Ensimmäinen tehtävä olisi laatia tekstitiedosto, joka sisältää harjoiteltavaksi tarkoitetun tekstin. Mitä pitempi, ja mitä monipuolisempaa kieliasultaan, sen parempi. Ohjelman tehtävä on ensi alkuun lukea kyseinen tekstitiedosto, rivittää se uudelleen ja poistaa kirjoituskelvottomat merkit (kuten rivinvaihdot, tms) tekstistä. Tähän tarvittavien rutiinien kokeilu olisi seuraavan jakson aiheena, eli tekstin lukeminen, manipulointi ja tulostaminen ruudulle.

[snifi]

Tekstitiedoston manipulointiin voisi käyttää vaikkapa seuraavanlaista koodia:

Koodia: [Valitse]

lineLen = 35

main = do
  originalText <- readFile ("hatupist.txt")
  print originalText
  let liness = colLines (collectWords (words (originalText)) lineLen)
  let lines = map (++" ") liness
  mapM_ putStrLn (lines)

colLines (xs:xss) =
  (unwords xs) : colLines xss
colLines [] = []

collectWords [] n = []
collectWords ys n =
  p1 : collectWords p2 n
  where
  (p1,p2) = splitAt (length (untilLen ys 0 n)) ys

untilLen (t:ts) s n
  | s+x<n || s==0  = t : untilLen ts (s+x) n
  | otherwise      = []
  where
  x = length t + 1
untilLen [] s n = []

Kirjoitetaan tekstitiedostoon hatupist.txt kokeilumielessä seuraava teksti:

Koodia: [Valitse]

Morse-aakkoset.

Graafinen muistisääntö.

Piirretään suuri A-kirjain. Väritetään kirjaimen huippupiste ja
vaakaviiva. A-kirjain on siten ti-taa.

Seuraavaksi piirretään I-kirjain. Väritetään kirjaimen molemmat päät.
I-kirjain on ti-ti.

E-kirjain on keskimmäisen poikkiviivan leikkauspiste pystyviivan kanssa.
E-kirjain on ti.

O-kirjaimessa on pitkästi ympyrän kehää väritettäväksi. Täytetään kehä
kolmella viivalla. O-kirjain on taa-taa-taa.

U-kirjaimesta väritetään molemmat huippupisteet ja pohjakaari. U-kirjain
on ti-ti-taa.

Edellinen ohjelmakoodi tulostaa nyt:

Koodia: [Valitse]

$ runhaskell luetiedosto.hs
"Morse-aakkoset.\n\nGraafinen muistis\228\228nt\246.\n\nPiirret\228\228n su
uri A-kirjain. V\228ritet\228\228n kirjaimen huippupiste ja vaakaviiva. A-k
irjain on siten ti-taa.\n\nSeuraavaksi piirret\228\228n I-kirjain. V\228rit
et\228\228n kirjaimen molemmat p\228\228t. I-kirjain on ti-ti.\n\nE-kirjain
 on keskimm\228isen poikkiviivan leikkauspiste pystyviivan kanssa. E-kirjai
n on ti.\n\nO-kirjaimessa on pitk\228sti ympyr\228n keh\228\228 v\228ritett
\228v\228ksi. T\228ytet\228\228n keh\228 kolmella viivalla. O-kirjain on ta
a-taa-taa.\n\nU-kirjaimesta v\228ritet\228\228n molemmat huippupisteet ja p
ohjakaari. U-kirjain on ti-ti-taa.\n\n"
Morse-aakkoset. Graafinen
muistisääntö. Piirretään suuri
A-kirjain. Väritetään kirjaimen
huippupiste ja vaakaviiva.
A-kirjain on siten ti-taa.
Seuraavaksi piirretään I-kirjain.
Väritetään kirjaimen molemmat
päät. I-kirjain on ti-ti.
E-kirjain on keskimmäisen
poikkiviivan leikkauspiste
pystyviivan kanssa. E-kirjain on
ti. O-kirjaimessa on pitkästi
ympyrän kehää väritettäväksi.
Täytetään kehä kolmella viivalla.
O-kirjain on taa-taa-taa.
U-kirjaimesta väritetään molemmat
huippupisteet ja pohjakaari.
U-kirjain on ti-ti-taa.

Tekstin manipulointiin tarvittavat rutiinit riippuvat hieman tekstitiedoston muodosta, ja periaatteessa tämän vaiheen voisi jopa sivuuttaa muokkaamalla tekstitiedosto valmiiksi tekstieditorilla. Haskell-kielen Prelude-kirjastosta käytettäviä funktioita olivat words ja unwords, joiden toimintaperiaate seuraavassa:

Koodia: [Valitse]

$ ghci
Prelude> let ws = words "U-kirjaimesta väritetään molemmat huippupisteet ja pohjakaari."
Prelude> ws
["U-kirjaimesta","v\228ritet\228\228n","molemmat","huippupisteet","ja","pohjakaari."]
Prelude> unwords ws
"U-kirjaimesta v\228ritet\228\228n molemmat huippupisteet ja pohjakaari."
Prelude> :q
Leaving GHCi.

Seuraavalla kerralla sijoittelemme komponentteja graafiseen ikkunaan. Käytettävät komponentit ovat edellisestä kuvasta 3xListStore, 2xImage, 2xLabel, TextBuffer, Statusbar. Lisäksi tarvitaan asemointia varten erinäinen määrä vboxeja, hboxeja ja separaattoreita.

[snifi]

Muutama tarvittava komponentti jotakuinkin oletusasetuksilla:

Koodia: [Valitse]

import Graphics.UI.Gtk

xxx = "xxxx xx xxx xxxxx xx xxxxxxx xxx xxxxxxxxxx xx."

main = do
  initGUI
  window <- windowNew
  onDestroy window mainQuit
 
  vbox <- vBoxNew False 0

  set window [
    containerBorderWidth := 10,
    windowTitle := "Hatupist",
    containerChild := vbox ]

  sep1       <- hSeparatorNew
  boxPackStart vbox sep1 PackNatural 3

  label1     <- labelNew (Just xxx)
  miscSetAlignment label1 0 0
  boxPackStart vbox label1 PackNatural 0

  label2     <- labelNew (Just xxx)
  miscSetAlignment label2 0 0
  boxPackStart vbox label2 PackNatural 0

  sep2       <- hSeparatorNew
  boxPackStart vbox sep2 PackNatural 3

  textview <- textViewNew
  boxPackStart vbox textview PackNatural 3
 
  statusbar <- statusbarNew
  set statusbar [ statusbarHasResizeGrip := False ]
  boxPackStart vbox statusbar PackNatural 5

  widgetShowAll window
  mainGUI
Tämä tuottaa seuraavanlaisen ikkunan:



Seuraavalla kerralla voisimme kokeilla tekstikentän puskurille tehtävää tapahtumankäsittelijää, jonka avulla päättelemme mitä käyttäjä on kirjoittanut ja minkä verran siitä on mennyt oikein, ja ehkä ajastimen toimintaa myös.

[snifi]

Asetaan tekstikentälle textview tekstipuskuri buffer. Tekstipuskuri lähettää signaalin onBufferChanged aina kun puskurin sisältö muuttuu.

Käyttötarpeisiimme sopivan kellonajan saamme järjestelmän POSIX-aikana. Tarvittava funktio getPOSIXTime löytyy kirjastosta Data.Time.Clock.POSIX.

Tämän lisäksi luodaan ajastin komennolla timeoutAdd. Ajastimen lähettämä signaali käsitellään funktiossa timeIsOut, ja se lähetetään 1000 millisekunnin eli noin sekunnin välein (järjestelmän kiireistä riippuen). Funktion palauttama arvo True kertoo, että ajastin jatkaa toimintaansa tapahtumankäsittelyn jälkeen.

Koodia: [Valitse]

import Graphics.UI.Gtk
import Data.Time.Clock.POSIX

xxx = "xxxx xx xxx xxxxx xx xxxxxxx xxx xxxxxxxxxx xx"

main = do
  initGUI
  window   <- windowNew
  onDestroy window mainQuit
 
  vbox     <- vBoxNew False 0

  set window [
    containerBorderWidth := 10,
    windowTitle := "Hatupist",
    containerChild := vbox ]

  label1   <- labelNew (Just xxx)
  miscSetAlignment label1 0 0
  boxPackStart vbox label1 PackNatural 0

  textview <- textViewNew
  boxPackStart vbox textview PackNatural 3
  buffer   <- textViewGetBuffer textview

  onBufferChanged buffer (bufferHasChanged buffer)

  timeoutAdd timeIsOut 1000

  widgetShowAll window
  mainGUI

bufferHasChanged buffer = do
  txt <- get buffer textBufferText
  pt  <- getPOSIXTime
  putStrLn ("Puskuri ## " ++ (show pt) ++ ": " ++ txt)
  return ()

timeIsOut = do
  pt <- getPOSIXTime
  putStrLn ("Ajastin ## " ++ show pt)
  return True

Ohjelma tulostaa tapahtumat päätteelle:

Koodia: [Valitse]

$ runhaskell simple-events.hs
Ajastin ## 1371671421.264802s
Ajastin ## 1371671422.266191s
Puskuri ## 1371671422.751292s: K
Ajastin ## 1371671423.266732s
Puskuri ## 1371671423.342312s: Ka
Puskuri ## 1371671423.86113s: Kau
Puskuri ## 1371671424.09616s: Kauk
Puskuri ## 1371671424.192814s: Kauka
Ajastin ## 1371671424.267482s
Puskuri ## 1371671424.380527s: Kaukan
Puskuri ## 1371671424.445665s: Kaukana
Ajastin ## 1371671425.269007s
Ajastin ## 1371671426.269852s
Seuraavalla kerralla yritämme sommitella taulukkokomponentteja tulostietojen näyttämiseen. Tarvittava komponentti (eli näkymä) on nimeltään treeView ja sen käyttämä malli ListStore.

[snifi]

Tässä on nopeasti kokoon kyhätty koodi tulostaulun näyttämiseen. Koodissa on monta kohtaa, jotka voisi vielä korvata lyhyemmällä silmukalla. En nyt vain tällä hetkellä vielä osaa oikein hyvin silmukoiden käyttöä monadin sisällä.

Koodia: [Valitse]

import Graphics.UI.Gtk
import Text.Printf

data Result = Result {
  date :: String, mrk :: Double,
  rank :: Int, errorPros :: Double
} deriving (Read, Show)

type Results = [Result]

zeroResult = Result {
  date = "0000-00-00 00:00:00",
  mrk = 0.0, rank = 0, errorPros = 0.0 }

main = do
  initGUI
  window   <- windowNew
  onDestroy window mainQuit

  -- treeview1
  model <- listStoreNew (replicate 3 zeroResult)
  view <- treeViewNewWithModel model

  set view [ widgetCanFocus := False ]

  col1 <- treeViewColumnNew
  col2 <- treeViewColumnNew
  col3 <- treeViewColumnNew
  col4 <- treeViewColumnNew

  treeViewColumnSetTitle col1 "Päiväys"
  treeViewColumnSetTitle col2 "Tulos"
  treeViewColumnSetTitle col3 "Sija"
  treeViewColumnSetTitle col4 "Virheitä"

  renderer1 <- cellRendererTextNew
  renderer2 <- cellRendererTextNew
  renderer3 <- cellRendererTextNew
  renderer4 <- cellRendererTextNew

  cellLayoutPackStart col1 renderer1 True
  cellLayoutPackStart col2 renderer2 True
  cellLayoutPackStart col3 renderer3 True
  cellLayoutPackStart col4 renderer4 True

  cellLayoutSetAttributes col1 renderer1 model (
    \row -> [ cellText := date row ])
  cellLayoutSetAttributes col2 renderer2 model (
    \row -> [ cellText := f01 (mrk row) ])
  cellLayoutSetAttributes col3 renderer3 model (
    \row -> [ cellText := showRank (rank row) ])
  cellLayoutSetAttributes col4 renderer4 model (
    \row -> [ cellText := f01 (errorPros row) ])

  treeViewAppendColumn view col1
  treeViewAppendColumn view col2
  treeViewAppendColumn view col3  
  treeViewAppendColumn view col4
  
  vbox     <- vBoxNew False 0
  boxPackStart vbox view PackNatural 3

  set window [
    containerBorderWidth := 10,
    windowTitle := "Hatupist",
    containerChild := vbox ]

  widgetShowAll window
  mainGUI

maxRank  = 5000

showRank rank
  | rank <= maxRank = show rank
  | otherwise       = ">" ++ show maxRank

f01 :: Double -> String
f01 = printf "%.1f"

Kirjastosta Text.Printf löytyy liukuluvun muotoiluun sopiva funktio printf. Se on kuormitettu funktio, joka tyyppiluokan Show instanssina palauttaa muotoillun merkkijonon, eikä siis nimestään huolimatta tulosta sitä, kuten se tyyppiluokan IO instanssina tekisi. Funktio f01 käyttää tätä funktiota. Liukuluvun muotoilumerkkijono annetaan samassa muodossa kuin muilla yleisillä ohjelmointikielillä.

Ohjelman tulostama ikkuna näyttää tällaiselta:

[snifi]

Silmukan rakentaminen onnistuu palauttamalla mieliin funktiot map ja zip, sekä määrittelemällä yksinkertainen nimetön lambda-funktio:

Koodia: [Valitse]

$ ghci
Prelude> map (4*) [1,3,5,7]
[4,12,20,28]
Prelude> let z = zip ['a','b','c'] [1,3,7]
Prelude> z
[('a',1),('b',3),('c',7)]
Prelude> map (\(h,j) -> (show j ++ [h])) z
["1a","3b","7c"]
Prelude>
Monadin sisällä funktio map tulee muotoon mapM. Näin ollen tulostaulu-ohjelma näyttää kokonaisuudessaan tältä:

Koodia: [Valitse]

import Graphics.UI.Gtk
import Text.Printf

data Result = Result {
  date :: String, mrk :: Double,
  rank :: Int, errors :: Double
} deriving (Read, Show)

zeroResult = Result {
  date = "0000-00-00 00:00:00",
  mrk = 0.0, rank = 0, errors = 0.0 }

main = do
  initGUI
  window   <- windowNew
  onDestroy window mainQuit

  -- treeview1
  model1 <- listStoreNew (replicate 3 zeroResult)
  view1 <- treeViewNewWithModel model1
  setupView view1 model1

  vbox     <- vBoxNew False 0
  boxPackStart vbox view1 PackNatural 3
  set window [ windowTitle := "Hatupist", containerChild := vbox ]
  widgetShowAll window
  mainGUI

colTitle = ["Päiväys",   "Tulos",     "Sija",        "Virheitä"    ]
colFunc  = [ date,        f01 . mrk,   show . rank,   f02p . errors]

setupView view model = do
  mapM
    ( \(title, func) -> newcol view model title func )
    ( zip colTitle colFunc )
  where
    newcol view model title func = do
      renderer <- cellRendererTextNew
      col <- treeViewColumnNew
      cellLayoutPackStart col renderer True
      cellLayoutSetAttributes col renderer model (
        \row -> [ cellText := func row])
      treeViewColumnSetTitle col title
      treeViewAppendColumn view col

f01 :: Double -> String
f01 = printf "%.1f"

f02p :: Double -> String
f02p = printf "%.2f%%"

Jatkossa muutokset tauluun tehdään mallin model1 kautta. Ja koska tulostauluja on kolme erilaista, voimme ehkä vielä tehdä toisen silmukan niiden näyttämiseksi.

[snifi]

Tuossa minun prototyypissäni ei ole laisinkaan valikkoa, mutta ajattelin, että tähän viralliseen versioon laitettaisiin sellainen. Nykyisin on tapana yhdistää toiminteet ja valikot yhdeksi kokonaisuudeksi, joten pelkän valikon rakentamiseen soveltuvaa koodia oli vaikea löytää. Tässä nyt kuitenkin jonkinlainen esimerkki, jota voidaan myöhemmin täydentää:

Koodia: [Valitse]

module Main (main) where

import Graphics.UI.Gtk

createMenuBar descr = do
  bar <- menuBarNew
  mapM_ (createMenu bar) descr
  return bar
  where
    createMenu bar (name,items) = do
      menu <- menuNew
      item <- menuItemNewWithLabelOrMnemonic name
      menuItemSetSubmenu item menu
      menuShellAppend bar item
      mapM_ (createMenuItem menu) items
    createMenuItem menu (stock,action) = do
      item <- imageMenuItemNewFromStock stock
      menuShellAppend menu item
      onActivateLeaf item action
    menuItemNewWithLabelOrMnemonic name
      | elem '_' name = menuItemNewWithMnemonic name
      | otherwise     = menuItemNewWithLabel name

noop = do
  return ()

menuBarDescr =
  [("_Tiedosto",
    [("gtk-open", noop),
     ("gtk-select-font", noop),
     ("gtk-preferences", noop),
     ("gtk-about", noop),
     ("gtk-quit", mainQuit)])
  ]

main = do
  initGUI
  window <- windowNew
  menuBar <- createMenuBar menuBarDescr
  set window [ windowTitle := "Manual Menubar Demo",
               containerChild := menuBar ]
  onDestroy window mainQuit
  widgetShowAll window
  mainGUI

Seuraavaksi teemme rutiinin, joka vaihtaa uuden tekstirivin aina sitä mukaa kuin käyttäjä saa edellisen valmiiksi.

[snifi]

Haskell-kielessä ei ole globaaleja muuttujia, joten niitä korvaamaan käytetään esimerkiksi IORef-kirjaston rutiineja. Viite muuttujiin luodaan komennolla newIORef, muuttujat luetaan komennolla readIORef ja kirjoitetaan komennolla writeIORef. Seuraavassa globaalit muuttujat on pyritty keräämään tietorakenteeseen State, jota myöhemmin täydennetään, ja muuttuja gs on viittaus tähän globaalien muuttujien kokoelmaan.

Ohjelman asetukset ovat tietorakenteessa Settings, ja niihin viitataan muuttujien settings ja defaultSettings avulla. Kukin globaali muuttuja ja asetusten muuttuja tulee näin ollen funktioksi, jonka ensimmäinen parametri on kokoelma, johon ne on sisällytetty, esimerkiksi  startLine settings tai currentLine gs.

Samaan tapaan kaikki tarvittavat viittaukset graafisiin komponentteihin on kerättynä tietorakenteeseen GUI, johon viitataan muuttujalla gui. Tästä saavutettava hyöty on, että funktioiden parametrien määrä pysyy kohtuullisena.

Olen käyttänyt tässä jo apumuuttujaa oLabelStrs tietoisena siitä, että tulemme myöhemmin napsimaan kirjaimia pois varsinaisen komponentin tekstistä.

Koodia: [Valitse]

import Graphics.UI.Gtk
import Data.IORef
import Control.Monad (when)

data GUI = GUI {
  gBuffer :: TextBuffer,
  gLabel1, gLabel2 :: Label
}

data State = State {
  oLabelStrs :: [String],
  currentLine :: Int
}

initState = State {
  oLabelStrs = ["",""],
  currentLine = 0
}

data Settings = Settings {
  lineLen :: Int, startLine :: Int,
  textfile :: String
} deriving (Read, Show)

defaultSettings = Settings {
  lineLen = 40, startLine = 0,
  textfile = "hatupist.txt"
}

settings = defaultSettings
xxx = replicate (lineLen defaultSettings) 'x'

main = do
  gs <- newIORef initState {
    currentLine = startLine settings
  }
  initGUI
  originalText <- readFile (textfile settings)
  let liness = colLines (collectWords (words (originalText)) (lineLen settings))
      lines = map (++" ") liness
  gui <- createGUI
  renewLabels gui (startLine settings) lines gs
  onBufferChanged (gBuffer gui) (
    whenBufferChanged gui settings lines gs)
  mainGUI

createGUI = do
  window <- windowNew
  onDestroy window mainQuit

  vbox <- vBoxNew False 0

  set window [
    containerBorderWidth := 10,
    windowTitle := "Hatupist",
    containerChild := vbox ]

  label1 <- labelNew (Just xxx)
  miscSetAlignment label1 0 0
  boxPackStart vbox label1 PackNatural 0

  label2 <- labelNew (Just xxx)
  miscSetAlignment label2 0 0
  boxPackStart vbox label2 PackNatural 0

  textview <- textViewNew
  boxPackStart vbox textview PackNatural 3
  buffer <- textViewGetBuffer textview

  widgetShowAll window
 
  return GUI {
    gBuffer = buffer,
    gLabel1 = label1,
    gLabel2 = label2
  }

renewLabels gui currentLine lines gsRef = do
  gs <- readIORef gsRef
  let labelStrs = labelStrings currentLine lines
  set (gLabel1 gui) [ labelLabel := labelStrs !! 0 ]
  set (gLabel2 gui) [ labelLabel := labelStrs !! 1 ]
  writeIORef gsRef gs {
    oLabelStrs = labelStrs
  }
  set (gBuffer gui) [ textBufferText := "" ]

labelStrings :: Int -> [String] -> [String]
labelStrings startline lines =
  [lines !! first] ++ [lines !! second]
  where
    first = startline `mod` (length lines)
    second = (startline + 1) `mod` (length lines)

whenBufferChanged gui settings lines gsRef = do
  gs  <- readIORef gsRef
  txt <- get (gBuffer gui) textBufferText
  let label1Str = head (oLabelStrs gs)
  when (label1Str == txt) (advanceLine gui lines gsRef gs)
  return ()

advanceLine gui lines gsRef gs = do
  writeIORef gsRef gs {
    currentLine = ncline
  }
  renewLabels gui ncline lines gsRef
  return ()
  where
    ncline = ((currentLine gs) + 1) `mod` (length lines)

colLines (xs:xss) =
  (unwords xs) : colLines xss
colLines [] = []

collectWords [] n = []
collectWords ys n =
  p1 : collectWords p2 n
  where
    (p1,p2) = splitAt (length (untilLen ys 0 n)) ys

untilLen (t:ts) s n
  | s+x<n || s==0  = t : untilLen ts (s+x) n
  | otherwise      = []
  where
    x = length t + 1
untilLen [] s n = []

Ohjelman avaama ikkuna näyttää tässä vaiheessa seuraavanlaiselta. Se lukee tekstitiedoston aikaisemmin esiteltyjä funktioita käyttäen, ja vaihtaa uuden tekstirivin edellisen tullessa valmiiksi.

[snifi]

Tänään ajattelin hahmotella millaisessa tilassa ohjelma milloinkin on. Vaihtoehdot luetellaan tietorakenteessa GameStatus:

Koodia: [Valitse]

data GameStatus = OldError | NewError | Correct | Back | NotStarted
  deriving (Eq, Show)

Tilatieto on takaisinkutsufunktioiden vaatima globaali muuttuja, joten se kuuluu tietorakenteeseen State, siellä olevien aikaisempien muuttujien joukkoon:

Koodia: [Valitse]

data State = State {
  status :: GameStatus,
  olabelStrs :: [String],
  currentLine :: Int
}

Tila voi saada yhden seuraavista arvoista:
NotStarted: Ohjelman käynnistyessä, kun yhtään merkkiä ei ole syötetty. Tilarivillä näytetään teksti "Voit aloittaa". Tulostaulut näyttävät nollaa, eikä ajastinta ole käynnistetty.
Correct: Käyttäjä on kirjoittanut tekstiä, ja teksti on oikein. Näppäimistönpainallukset rekisteröidään.
NewError: Käyttäjä on lyönyt virhelyönnin. Virhe rekisteröidään ja käyttäjää pyydetään korjaamaan virheet. Ohjelma siirtyy tilaan OldError.
OldError: Ohjelma on tässä tilassa siihen saakka kunnes teksti on jälleen oikein, jolloin siirrytään takaisin tilaan Correct. Uusia virheitä ei rekisteröidä, jolloin yksi lyöntivirhe vastaa yhtä virhettä tilastossa ja käyttäjä voi korjata tekstin.
Back: Teksti on oikein, mutta käyttäjä (jostain syystä) poistaa merkkejä. Näppäimistönpainalluksista ei tällöin synny rekisteröitävää tietoa.

Tila saadaan seuraavan algoritmin avulla:

Koodia: [Valitse]

getStatus :: String -> String -> Int -> GameStatus
getStatus written goal tlen
  | a == b && c < d  = Correct
  | a == b           = Back
  | otherwise        = NewError
  where
    a = written
    b = commonPrefix written goal
    c = tlen
    d = length written

Tässä parametri written on merkkijono, joka kertoo mitä käyttäjä on kirjoittanut tekstikenttään. Parametri goal on merkkijono, joka kertoo tavoitteen, mitä olisi pitänyt kirjoittaa, eli käytännössä se on tekstirivi komponentista Label1, tai tarkemmin ottaen oLabelStr1, jota käsiteltiin viime kerralla. Parametri tlen on aikaisemman näppäimistönpainalluksen yhteydessä talteen otettu kirjoitetun tekstin pituus. Tämän perusteella voidaan päätellä lisäsikö käyttäjä tekstiä vai poistiko sitä.

Funktio commonPrefix palauttaa merkkijonon, joka kuvastaa minkä verran kahden parametrina annetun merkkijonon alussa on samaa tekstiä. Se on määritelty seuraavasti:

Koodia: [Valitse]

commonPrefix (x:xs) (y:ys)
  | x == y    = x : commonPrefix xs ys
commonPrefix _ _ = []

Lopuksi vielä virheen sattuessa selvitetään oliko kysymyksessä uusi vai vanha virhe. Aikaisemman tilan ollessa Correct tai NotStarted, on kysymyksessä uusi virhe. Muutoin on kysymyksessä vanha virhe:

Koodia: [Valitse]

oldNewError Correct = NewError
oldNewError NotStarted = NewError
oldNewError _ = OldError


[snifi]

Nyt kun ajattelen tarkemmin, niin ehkä selviäisimme paremmin yksinkertaisemmalla määrittelyllä:

Koodia: [Valitse]

data GameStatus = Error | Correct | Back | NotStarted
  deriving (Eq, Show)

Tällöin tarkasteltaviksi tapauksiksi tulisivat (status,oldStatus)-parit, ja puskurin muutoksiin vastaava koodi näyttäisi nyt alkuvaiheessa seuraavalta:

Koodia: [Valitse]

whenBufferChanged gui settings lines gsRef = do
  gs  <- readIORef gsRef
  txt <- get (gBuffer gui) textBufferText
  let label1Str = head (oLabelStrs gs)
      status = getStatus txt label1Str (oldlen gs)
      f = case (status,oldStatus gs) of
        (_,NotStarted)  -> whenNotStarted status
        (Correct,_)     -> whenCorrect
        (Error,Correct) -> whenNewError
        otherwise       -> whenOther status (oldStatus gs)
  print (status,oldStatus gs, txt)
  f gui settings lines gsRef gs
  writeIORef gsRef gs {
    oldStatus = status,
    oldlen = max (length (commonPrefix txt label1Str)) (oldlen gs)
  }
  when (label1Str == txt) (advanceLine gui lines gsRef gs)
  return ()

whenNotStarted status gui settings lines gsRef gs = do
  putStrLn ("Started with " ++ (show status))
  return ()

whenCorrect gui settings lines gsRef gs = do
  print "Correct."
  return ()

whenNewError gui settings lines gsRef gs = do
  print "New Error."
  return ()

whenOther status oldStatus gui settings lines gsRef gs = do
  putStrLn ("Other with " ++ (show (status,oldStatus)))
  return ()

Tyypillinen tuloste kokeiltaessa edellistä näyttää tältä:

Koodia: [Valitse]

(Correct,NotStarted,"M")
Started with Correct
(Correct,Correct,"Mo")
"Correct."
(Error,Correct,"Mou")
"New Error."
(Back,Error,"Mo")
Other with (Back,Error)
(Correct,Back,"Mor")
"Correct."
(Back,Correct,"Mo")
Other with (Back,Correct)

Tietorakenteeseen State täytyy luonnollisesti lisätä kenttä oldlen:

Koodia: [Valitse]

data State = State {
  oldStatus :: GameStatus,
  oldlen :: Int,
  oLabelStrs :: [String],
  currentLine :: Int
}

initState = State {
  oldStatus = NotStarted,
  oLabelStrs = ["",""],
  oldlen = 0,
  currentLine = 0
}

Ja funktiossa advanceLine saavutukset nollataan rivinvaihdon vuoksi:

Koodia: [Valitse]

advanceLine gui lines gsRef gs = do
  writeIORef gsRef gs {
    currentLine = ncline,
    oldlen = 0
  }
  renewLabels gui ncline lines gsRef
  return ()
  where
    ncline = ((currentLine gs) + 1) `mod` (length lines)

Seuraavaksi tarvitsemme loput tulostaulukomponentit, ja alamme kokeilemaan ajanottoa.

[snifi]

Ohjelman ajatus on, että kirjoitusnopeuden mittaus jaetaan puolen minuutin intervalleihin (jatkossa i-etuliite nimissä). Varsinainen tulos on neljän peräkkäisen intervallin merkkimäärien summa, eli kahden minuutin jakso. Tuloksia ylläpitävä tietorakenne on nimeltään Result (r-etuliite nimissä). Istunnolla (Session, s-etuliite) puolestaan tarkoitetaan ajanjaksoa ensimmäisen merkin syöttämisestä ikkunan sulkemiseen, tietorakenne Timing.

Koodia: [Valitse]

iDuration = 30
rDuration = 120
amountOfIntervals = rDuration `div` iDuration

data Result = Result {
  rDate :: String,
  rMrks, rRank, rErrs :: Int
} deriving (Read, Show)

zeroResult = Result {
  rDate = "0000-00-00 00:00:00",
  rMrks = 0, rRank = 0, rErrs = 0 }

data Timing = Timing {
  sSession :: String, sTotal :: Int,
  sSecsLeft :: Int,   sSpeed :: Double
} deriving Show

zeroTiming = Timing {
  sSession = "00:00", sTotal = 0,
  sSecsLeft = iDuration, sSpeed = 0.0 }

data Interval = Interval {
  iNum, iMrks, iErrs :: Int
} deriving Show

zeroInterval = Interval {
  iNum = -1, iMrks = 0, iErrs = 0 }

Näitä kolmea tietorakennetta kohden on oma tulostaulunsa ohjelman ikkunassa. Tulostauluun luotava alustava malli, sarakkeiden otsikot ja tätä vastaava funktio solun sisällön tulostamiseksi on määritelty seuraavassa:

Koodia: [Valitse]

rInitModel = replicate 3 zeroResult
rColTitles = ["Päiväys", "Tulos",         "Sija",        "Virheitä" ]
rColFuncs  = [ rDate,     rSpeed . rMrks,  show . rRank,  rErrorPros]

sInitModel = [zeroTiming]
sColTitles = ["Istunto", "Yhteensä",     "Jakso",          "Jaksonopeus"]
sColFuncs  = [ sSession,  show . sTotal,  show . sSecsLeft, f01 . sSpeed]

iInitModel = replicate amountOfIntervals zeroInterval
iColTitles = ["Alkoi",        "Päättyi",    "Nopeus",       "Virheitä" ]
iColFuncs  = [ iStarts . iNum, iEnds . iNum, iSpeed . iMrks, iErrorPros]

Käyttöliittymä luodaan tuttuun tapaan funktiossa createGUI:

Koodia: [Valitse]

createGUI = do
  window <- windowNew
  onDestroy window mainQuit

  outerVBox  <- vBoxNew False 0
  middleHBox <- hBoxNew False 0
  innerVBox1 <- vBoxNew False 0
  innerVBox2 <- vBoxNew False 0

  rModel <- setupView rInitModel rColTitles rColFuncs innerVBox1
  sModel <- setupView sInitModel sColTitles sColFuncs innerVBox1
  iModel <- setupView iInitModel iColTitles iColFuncs innerVBox2

  boxPackStart middleHBox innerVBox1 PackNatural 0
  boxPackStart middleHBox innerVBox2 PackNatural 6
  boxPackStart outerVBox middleHBox PackNatural 10

  set window [
    containerBorderWidth := 10,
    windowTitle := "Hatupist",
    containerChild := outerVBox ]

  label1 <- labelNew (Just xxx)
  miscSetAlignment label1 0 0
  boxPackStart outerVBox label1 PackNatural 0

  label2 <- labelNew (Just xxx)
  miscSetAlignment label2 0 0
  boxPackStart outerVBox label2 PackNatural 0

  textview <- textViewNew
  boxPackStart outerVBox textview PackNatural 3
  buffer <- textViewGetBuffer textview

  widgetShowAll window
  
  return GUI {
    gBuffer = buffer,
    gLabel1 = label1,
    gLabel2 = label2
  }

Tulostaulujen näkymä luodaan funktiolla setupView, joka tässä vaiheessa näyttää seuraavalta:

Koodia: [Valitse]

setupView initModel titles funcs parent = do
  model <- listStoreNew (initModel)
  view  <- treeViewNewWithModel model
  mapM
    ( \(title, func) -> newcol view model title func )
    ( zip titles funcs )
  set view [ widgetCanFocus := False ]
  boxPackStart parent view PackNatural 3
  return model
  where
    newcol view model title func = do
      renderer <- cellRendererTextNew
      col <- treeViewColumnNew
      cellLayoutPackStart col renderer True
      cellLayoutSetAttributes col renderer model (
        \row -> [ cellText := func row])
      treeViewColumnSetTitle col title
      treeViewAppendColumn view col

Solutekstien muotoilemiseen on erinäinen määrä apufunktioita, joiden toimintalogiikkaan ei tässä vaiheessa kannattane kiinnittää suurempaa huomiota:

Koodia: [Valitse]

rErrorPros rR =
  f02p (errorPros (rErrs rR) (rMrks rR))

iErrorPros iV =
  f02p (errorPros (iErrs iV) (iMrks iV))

errorPros errs mrks
  | errs == 0 && mrks == 0 = 0.0
  | errs /= 0 && mrks == 0 = 100.0
  | otherwise = 100.0 * (intToDouble errs) / (intToDouble mrks)

f01 :: Double -> String
f01 = printf "%.1f"

f02p :: Double -> String
f02p = printf "%.2f%%"

iSpeed mrks =
  f01 ((intToDouble mrks)* 60.0 / intToDouble iDuration)

rSpeed mrks =
  f01 ((intToDouble mrks)* 60.0 / intToDouble rDuration)

iStarts n
  | n <= 0    = "00:00"
  | otherwise = mmss (fromIntegral (n*iDuration) :: Double)

iEnds n = iStarts (n+1)

mmss seconds =
  leadingZero (show (floor seconds `div` 60)) ++
  ":" ++
  leadingZero (show (floor seconds `mod` 60))

leadingZero s
  | length s < 2 = "0" ++ s
  | otherwise    = s

intToDouble :: Int -> Double
intToDouble i = fromRational (toRational i)

Ohjelman tuottama ikkuna näyttää nyt tältä:

[snifi]

Intervallit eli kolmenkymmenen sekunnin jaksot on siis määritelty tietorakenteessa Interval, ja alustamaton oletusintervalli on nimeltään zeroInterval, sen tuntee numerosta -1. Lyöntimäärät ja virheet lasketaan kenttiin iMrks ja iErrs.

Koodia: [Valitse]

data Interval = Interval {
  iNum, iMrks, iErrs :: Int
} deriving Show

zeroInterval = Interval {
  iNum = -1, iMrks = 0, iErrs = 0 }

Tietorakenteeseen State lisätään aloitusaikaa kuvaava kenttä startTime, joka alustetaan epämääräiseen nolla-aikaan vuoteen 1970.

Koodia: [Valitse]

data State = State {
  status :: GameStatus,
  startTime :: POSIXTime,
  ...

initState = State {
  startTime = fromIntegral 0 :: POSIXTime,
  oldStatus = NotStarted,
  ...

Kun lyönnin aika t sekunteina tunnetaan, saadaan intervallin numero, johon lyönti kuuluu, yksinkertaisella funktiolla:

Koodia: [Valitse]

intervalNumber t =
  floor t `div` iDuration

POSIXtime-tyyppi (ja jatkossa lyhenne pt) on kellonaika alkaen vuodesta 1970 sekunteina, joten se käy sekuntimäärien vertailemiseen yksinkertaisella tyyppimuunnoksella:

Koodia: [Valitse]

secondsFrom startPt endPt =
  a - b
  where
    a = ptToDouble endPt
    b = ptToDouble startPt

ptToDouble :: POSIXTime -> Double
ptToDouble t  = fromRational (toRational t)
intToDouble :: Int -> Double
intToDouble i = fromRational (toRational i)

Tässä funktiot from/toRational ovat jälleen esimerkkejä tyyppiluokkien mukaan kuormitetuista funktioista, eli ne tekevät muunnoksen annettujen tyyppimäärittelyjen mukaisesti.

Puskurin muutoksiin vastaava koodi on nyt seuraavassa muodossa:

Koodia: [Valitse]

whenBufferChanged gui settings lines gsRef = do
  pt  <- getPOSIXTime
  gs  <- readIORef gsRef
  txt <- get (gBuffer gui) textBufferText
  let label1Str = head (oLabelStrs gs)
      status = getStatus txt label1Str (oldlen gs)
      f = case (status,oldStatus gs) of
        (_,NotStarted)  -> whenNotStarted status
        (Correct,_)     -> whenCorrect
        (Error,Correct) -> whenNewError
        otherwise       -> whenOther status (oldStatus gs)
  newgs <- f gui settings lines pt gs
  writeIORef gsRef newgs {
    oldStatus = status,
    oldlen = max (length (commonPrefix txt label1Str)) (oldlen gs)
  }
  when (label1Str == txt) (advanceLine gui lines gsRef gs)
  return ()

whenNotStarted status gui settings lines pt gs = do
  putStrLn ("Started with " ++ (show status))
  return gs {
    startTime = pt
  }

whenCorrect gui settings lines pt gs = do
  print "Correct."
  let s = secondsFrom (startTime gs) pt
      i = intervalNumber s
  print (s,i)
  return gs

whenNewError gui settings lines pt gs = do
  print "New Error."
  return gs

whenOther status oldStatus gui settings lines pt gs = do
  putStrLn ("Other with " ++ (show (status,oldStatus)))
  return gs

Ja yrittäessäni naksutella noin yhden merkin viidessä sekunnissa, saatiin seuraava tuloste, josta näkyy kulunut sekuntimäärä ja intervalli, johon näppäimistönpainallus kuuluu:

Koodia: [Valitse]

$ runhaskell ajanottoa-01.hs
Started with Correct
"Correct."
(3.952288866043091,0)
"Correct."
(9.909076929092407,0)
"Correct."
(15.482538938522339,0)
"Correct."
(20.866790771484375,0)
"Correct."
(26.18815588951111,0)
"Correct."
(31.308336973190308,1)
"Correct."
(36.21953082084656,1)

Ensi kerralla käytämme tätä hyväksi, ja keräämme nämä tiedot niitä vastaaviin tietorakenteisiin.

[snifi]

Jotta tulostaulujen sisältöä päästään muuttamaan, tarvitaan siis viitteet näiden taulujen malleihin:

Koodia: [Valitse]

data GUI = GUI {
  gBuffer :: TextBuffer,
  gLabel1, gLabel2 :: Label,
  gModelR :: ListStore Result,
  gModelS :: ListStore Timing,
  gModelI :: ListStore Interval
}

Nämä viitteet luotiin funktiossa createGUI:

Koodia: [Valitse]

  rModel <- setupView rInitModel rColTitles rColFuncs innerVBox1
  sModel <- setupView sInitModel sColTitles sColFuncs innerVBox1
  iModel <- setupView iInitModel iColTitles iColFuncs innerVBox2
  ...
  return GUI {
    gBuffer = buffer,
    gLabel1 = label1, gLabel2 = label2,
    gModelR = rModel, gModelS = sModel, gModelI = iModel
  }

S-taulun ainoa rivi (rivinumero 0) päivitetään nyt funktiolla listStoreSetValue. Sen parametrit ovat viite malliin (gModelS gui), rivinumero ja tietorakenne Timing, joka sisältää näytettävien kenttien saamat arvot.

Koodia: [Valitse]

renewTableS gui gs t = do
  listStoreSetValue (gModelS gui) 0 Timing {
    sSecsLeft = iLeft t,
    sSession = mmss t,
    sTotal = total gs,
    sSpeed = 0.0
  }

Ensimmäisen näppäimistönpainalluksen seurauksena kutsuttavaan funktioon whenNotStarted on lisätty komento timeoutAdd, joka käynnistää ajastimen.

Koodia: [Valitse]

whenNotStarted status gui settings lines pt gsRef gs = do
  putStrLn ("Started with " ++ (show status))
  timeoutAdd (onTimeout gui gsRef) 500

Ajastimen toiminta määritellään seuraavassa:

Koodia: [Valitse]

onTimeout gui gsRef = do
  gs <- readIORef gsRef
  pt <- getPOSIXTime
  let t = secondsFrom (startTime gs) pt
      iCur = iNumber t
  renewTables gui gs t iCur
  writeIORef gsRef gs {
    lastShownIv = iCur
  }
  return True

Pienet apufunktiot iNumber ja iLeft kertovat jakson numeron ja paljonko jaksossa on sekunteja jäljellä.

Koodia: [Valitse]

iNumber t =
  floor t `div` iDuration

iLeft t =
  iDuration - (floor t `mod` iDuration)

Tilastoitavat näppäimistönpainallukset kerätään oikeisiin intervalleihin funktiossa addTime:

Koodia: [Valitse]

addTime status i intervals =
  [newHead] ++ tail newIvs
  where
  newHead = case status of
    Correct -> headIv { iMrks = (iMrks headIv) + 1 }
    Error   -> headIv { iErrs = (iErrs headIv) + 1 }
  headIv = head newIvs
  newIvs = if i /= latestIvNum intervals
    then [zeroInterval { iNum = i }] ++ intervals
    else intervals

Käytännössä nämä muodostavat kasvavan taulukon, jossa kenttä iNum kertoo jakson numeron, ja kentät iMrks ja iErrs lyöntimäärät ja virheet seuraavaan tapaan:

Koodia: [Valitse]

[Interval {iNum = 1, iMrks = 9, iErrs = 0},Interval {iNum = 0, iMrks = 68, iErrs = 2}]

Jatkamme tulostietojen käsittelemistä ensi kerralla. Ohjelmakoodi tähän mennessä http://personal.inet.fi/koti/jhii/ajanottoa-03.hs

[snifi]

Tulostauluja on siis kolme, näistä istunnon S-taulu päivitetään puolen sekunnin välein. Kaksi muuta taulua päivitetään, kun siirrytään intervallista toiseen. Monadin sisällä tämä ehtolause ei ole kovin selkeästi luettava, mutta se on seuraavassa:

Koodia: [Valitse]

renewTables gui gs t iCur = do
  renewTableS gui gs t
  newGs <- if (lastShownIv gs /= iCur)
  then renewSeldomTables gui gs iCur
  else return gs
  return newGs

Intervallien I-taulun päivityksen yhteydessä lasketaan kahden minuutin tulos ja siivotaan pois tarpeettomat intervallit:

Koodia: [Valitse]

renewTableI gui gs iCur = do
  mapM
    (\(a,b) -> listStoreSetValue (gModelI gui) (amountOfIntervals-a) b)
    (zip [1..] showIvs)
  return gs {
    intervals = newIvs,
    lastShownIv = iCur,
    results = [zeroResult {
       rMrks = sum [iMrks g | g <- showIvs]
    }]
  }
  where
    iMaxShow = iCur - 1
    infimum = iMaxShow - amountOfIntervals + 1
    iMinShow = max 0 infimum
    iMinNeed = max 0 (infimum + 1)
    newIvs = ivsFrom iMinNeed (intervals gs)
    showIvs = reverse (ivsAllBetween iMinShow iMaxShow (intervals gs))

Näytettävien intervallien alaraja on muuttuja iMinShow ja yläraja iMaxShow. Seuraavaan kertaan näistä ei tarvitse säilyttää alarajan intervallia, joten tarvittavien intervallien alaraja iMinNeed on yhden korkeampi. Uudet intervallit ovat nyt siis taulukossa newIvs ja näytettävät intervallit taulukossa showIvs. Kahden minuutin tulos saadaan laskemalla merkkimäärät näytettävistä intervalleista kaavalla

Koodia: [Valitse]

rMrks = sum [iMrks g | g <- showIvs]

Tässä vaiheessa heitämme tuon laskun tuloksen yksinkertaisesti tulosten R-taulun alimmalle riville:

Koodia: [Valitse]

latestResult results = if null results
  then zeroResult
  else head results

renewTableR gui gs iCur = do
  listStoreSetValue (gModelR gui) 2 (latestResult (results gs))
  return ()

Pienet apufunktiot, joita käytämme intervallien suodattamiseen, ovat esitettynä seuraavassa. Intervalleihin ei taltioidu nollatuloksia, mutta I-taulussa ne halutaan näyttää, ja tästä syystä määrittelemme funktiot ivsAllBetween ja ivExactly.

Koodia: [Valitse]

ivsBetween iMin iMax ivs =
  filter (\iv -> iMin <= (iNum iv) && (iNum iv) <= iMax) ivs

ivsFrom iMin ivs =
  filter (\iv -> iMin <= (iNum iv)) ivs

ivsAllBetween iMin iMax ivs =
  [ivExactly n ivs | n <- [iMin .. iMax]]

ivExactly n ivs =
  case find (\iv -> n == (iNum iv)) ivs of
    Just x  -> x
    Nothing -> zeroInterval { iNum = n }

Kirjoitusnopeus kauniissa muodossa merkkijonona esitettynä saatiin jakamalla merkkimäärä aikavälin pituudella (mrk/min, jossa 1min=60.0s).

Koodia: [Valitse]

rSpeed mrks =
  f01 ((intToDouble mrks)* 60.0 / intToDouble rDuration)

Havaitsin, että olin aikaisemmin funktiossa addTime aika varomattomasti luottanut taulukon olevan ei-tyhjä. Olen korjannut tämän ja lisännyt joitakin muita virheitä lähdekoodiin.

Koodia: [Valitse]

if null intervals ||

Kokeiluversio löytyy täältä http://personal.inet.fi/koti/jhii/taulut-01.hs
(Koodaus UTF-8, mikäli jotkin merkit näkyvät väärin.)

[snifi]

Laskimme edellisellä kerralla intervallit, joilla on merkitystä tuloksen määräytymisessä. Nyt käytämme näiden intervallien taulukkoa parametrina, ja laskemme kyseisen tuloksen:

Koodia: [Valitse]

addResult showIvs gs = do
  pt <- getPOSIXTime
  tz <- getCurrentTimeZone
  let newResult0 = zeroResult {
    rDate  = timeFormatted (utcToZonedTime tz (posixSecondsToUTCTime pt)),
    rMrks = sum [iMrks g | g <- showIvs],
    rErrs = sum [iErrs g | g <- showIvs]
  }
  let newResult = newResult0 {
    rRank = tellRank newResult0 (results gs)
  }
  let
    newRs = take maxRank (insert newResult (results gs))
    newShownRs = [
      bestResult newRs,
      (sessionBest gs) `min` newResult,
      newResult ]
  return (newRs, newShownRs)

timeFormatted :: ZonedTime -> String
timeFormatted = formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S"

tellRank x xs =
  case findIndex (x <=) xs of
    Just n  -> n + 1
    Nothing -> length xs + 1

Muuttuja newResult0 on päivämäärän, merkkimäärän ja virhemäärän sisältävä nimetty tietue. Sitä tarvitaan välituloksena, jotta voimme selvittää mille sijalle tuloksissa saavutettu kirjoitusnopeus sijoittuu. Muuttuja newResult on vastaava tietue, johon on lisätty kyseinen sijoitus, rRank. Sijoitus saadaan funktiosta tellRank. Tulostauluun määrittelemme tilaa viidelletuhannelle tulostietueelle. Uusi tulos lisätään oikeaan kohtaan taulukkoon newRs funktiolla insert, ja tämän jälkeen taulukko typistetään tulostaulun maksimipituuteen funktiolla take.

Tulosten vertaileminen toisiinsa perustuu tyyppiluokkien Eq ja Ord hyväksikäyttöön. Kirjastosta List löytyy koko joukko funktioita, jotka osaavat käyttää tätä ominaisuutta hyväksi, esimerkiksi funktio insert.  Luomme tietorakenteelle Result instanssin näihin tyyppiluokkiin. Tuloksia kohdellaan samana, mikäli niiden merkkimäärä ja päivämäärä ovat samat. Samaan merkkimäärään päädyttäessä aikaisemmin saavutettua tulosta pidetään parempana verrattuna myöhemmin saavutettuun. Virhemäärä on mukana ainoastaan informaation vuoksi.

Koodia: [Valitse]

data Result = Result {
  rDate :: String,
  rMrks, rRank, rErrs :: Int
} deriving (Read, Show)

instance Eq Result where
  (Result a b c d) == (Result aa bb cc dd) =
    b == bb && a == aa

instance Ord Result where
  (Result a b c d) `compare` (Result aa bb cc dd) =
    if (b == bb) then (a `compare` aa) else (bb `compare` b)

Funktio addResult palauttaa päivitetyn tulostaulun lisäksi toisena tietueen alkiona taulukon newShownRs, johon on laskettuna kolme erityistä tulosta näytettäväksi ruudulla:

Koodia: [Valitse]

    newShownRs = [
      bestResult newRs,
      (sessionBest gs) `min` newResult,
      newResult ]

bestResult results = if null results
  then zeroResult
  else head results

Ensimmäinen näistä on kaikkien aikojen paras tulos, toinen istunnon paras tulos ja kolmas viimeisin tulos. Näistä kaikkien aikojen paras tulos on sama kuin istunnon paras tulos, sillä emme toistaiseksi lainkaan tallenna tuloksia. Myös tässä funktio min käyttää hyväksi järjestysominaisuutta, joka on seurausta tyyppiluokkiin Eq ja Ord kuulumisesta.

Jätimme aikaisemmin toteuttamatta S-taulun sarakkeen "Jaksonopeus" laskemisen. Tulin ajatelleeksi, että ehkä sittenkin laskemme tuohon sarakkeeseen hetkellisen nopeuden kymmenen viimeisen sekunnin osalta. Muutamme S-taulun päivitysalgoritmia saadaksemme tarvittavat tiedot talteen:

Koodia: [Valitse]

renewTableS gui gs t = do
  pt <- getPOSIXTime
  let newGs = gs {
    speedNows = [(pt, (total gs))] ++ take speedCount (speedNows gs)
  }
  let s = difs (speedNows newGs)
  listStoreSetValue (gModelS gui) 0 Timing {
    sSecsLeft = iLeft t,
    sSession = mmss t,
    sTotal = total gs,
    sSpeed = speed (snd s) (fst s)
  }
  putStrLn (show (snd s) ++ " merkkiä " ++ f01 (fst s) ++ " sekunnissa")
  return newGs

Tässä speedNows gs on taulukko, johon keräämme kellonajan ja kellonaikaa vastaavan kokonaismerkkimäärän total gs. Kun nyt laskemme näiden kunkin erotuksen taulukon alusta ja lopusta, saamme hetkellisen kirjoitusnopeuden:

Koodia: [Valitse]

difs speds =
  if null speds
    then (0.0, 0)
    else (secondsFrom (fst start) (fst end), (snd end) - (snd start))
  where
    start  = last speds
    end    = head speds

speed mrks t =
  (intToDouble mrks) * 60.0 / (max t 1.0)

Olen tässä jälleen käyttänyt epämääräisiä keinoja huolehtimaan, ettei synny nollalla jakoa tai pään etsimistä tyhjästä listasta.

Ohjelmakoodi tähän mennessä http://personal.inet.fi/koti/jhii/taulut-02.hs

[snifi]

Kirjasin muutetaan funktiossa setFonts, missä vaadittava parametri fontstring saa arvon "monospace". Tekstin kokoa voi muuttaa lisäämällä merkkikoon, esimerkiksi "monospace 12". Tasalevyistä kirjoituskonekirjasinta tarvitaan, jotta voimme tyhjentää merkkijonon välilyönneillä kun käyttäjä kirjoittaa sitä. Toinen vaihtoehto olisi piirtää merkkijonot itse, jolloin käyttäisimme funktiota textExtents selvittämään tyhjennettävän osuuden dimensiot. Tämä mahdollistaisi myös muiden kirjasimien käytön.

Koodia: [Valitse]

setFonts gui fontstring = do
  srcfont <- fontDescriptionFromString fontstring
  widgetModifyFont (gLabel1 gui) (Just srcfont)
  widgetModifyFont (gLabel2 gui) (Just srcfont)
  widgetModifyFont (gTextview gui)  (Just srcfont)

Olkoon nyt n kirjoitettujen merkkien lukumäärä. Näytettävä merkkijono on tällöin n kappaletta välilyöntejä lisättynä merkkijonon häntään, joka jää jäljelle pudottamalla n merkkiä pois alusta:

Koodia: [Valitse]

blankStart n str =
  replicate n ' ' ++ drop n str

Käytämme hyväksemme funktiota commonPrefix, ja teemme tarvittavat muutokset puskurin muutokseen vastaavaan tapahtumankäsittelijään whenBufferChanged:

Koodia: [Valitse]

cprfix = length (commonPrefix txt label1Str)

  set (gLabel1 gui) [
    labelLabel := blankStart cprfix label1Str]

Ohjelman peruslogiikka alkaa olla valmiina, kunhan vielä tallennamme tulokset. Olemme aikaisemmin määritelleet tulostietotyypin periytymään tyyppiluokista Show ja Read, joten tietorakenteen lukeminen ja kirjoittaminen on automaattista. Periaattessa tulokset luetaan yksinkertaisten funktioiden readFile ja read avulla.

Vanhoja tuloksia lukiessamme saatamme todennäköisesti törmätä kahteen ongelmaan: tulostiedostoa ei ole olemassa tai tulostiedot eivät ole jäsenneltävässä muodossa. Kirjastossa System.IO.Error on funktio try, joka sopii virheenhallintaan. Tyyppiä IO a olevalle parametrille se palauttaa arvon tyyppiä IO (Either IOError a), joka on Left e virheen sattuessa ja Right i muutoin. Emme tässä ole kiinnostuneita virheen laadusta, vaan palautamme tyhjän tulostaulukon:

Koodia: [Valitse]

resultsFromFile fname = do
  opResult <- try ( do
    content <- readFile fname
    readLst content )
  case opResult of
    Left excp -> return []
    Right val -> return val

readLst :: String -> IO [Result]
readLst = readIO    

Kaikenkaikkiaan alustustietojen luomiseen ja lukemiseen käytettävä funktio getStartupConfig näyttää tässä vaiheessa seuraavalta. Oletuksena on, että ohjelman käyttämät tiedostot tallennetaan vastedes piilohakemistoon "/home/user/.hatupist/", joka luodaan, jollei sitä ole:

Koodia: [Valitse]

getStartupConfig gui gsRef = do
  gs <- readIORef gsRef
  -- directory
  homedir <- getHomeDirectory
  let dir = homedir ++ "/.hatupist"
  createDirectoryIfMissing False (dir)
  -- savedResults
  let rname = dir ++ "/" ++ resultsFile
  oldResults <- resultsFromFile rname
  putStrLn ("Reading " ++ rname ++ ": " ++ show (length (oldResults)) ++ " rows")
  listStoreSetValue (gModelR gui) 0 (bestResult oldResults)
  -- other
  setFonts gui "monospace"
  writeIORef gsRef gs {
    homeDirectory = dir,
    results = oldResults
  }

resultsFile = "results.txt"

Vastaavasti tulokset tallennetaan ohjelman päättyessä funktioiden writeFile ja show avulla:

Koodia: [Valitse]

quitProgram gsRef = do
  print "Quitting."
  gs <- readIORef gsRef
  let rname = (homeDirectory gs) ++ "/" ++ resultsFile
  writeFile rname (show (results gs))
  putStrLn ("Saving " ++ rname)
  mainQuit

Ohjelmakoodi tähän mennessä: http://personal.inet.fi/koti/jhii/savedResults-01.hs

Ohjelman ikkuna näyttää nyt tältä:

[snifi]

Ohjelman versioissa tähän asti olemme välittäneet funktion tarvitsemat tiedot parametreina, esimerkiksi:

Koodia: [Valitse]

whenBufferChanged gui settings lines gsRef = do

Lukuisten kokeiluiden seurauksena päädyin luopumaan tästä tavasta ja siirtämään parametrit tietorakenteen State alaisuuteen. Funktiokutsut tulevat tällöin muotoon

Koodia: [Valitse]

whenBufferChanged gsRef = do
  ...

Tietorakenne State sisältää nyt muun muassa seuraavat kentät:

Koodia: [Valitse]

data State = State {
  textLines :: [String],
  speedNows :: [(POSIXTime, Int)],
  intervals :: [Interval],
  results :: [Result],
  settings :: Settings,
  gui :: GUI
}

Säästääksemme hieman kirjoitusvaivaa, määrittelemme seuraavat lyhennysmerkinnät:

Koodia: [Valitse]

s gs = settings gs
g gs = gui gs
r gs = results gs

Voimme nyt kutsua tietorakenteen State sisältämiä kenttiä seuraavaan tapaan:

Koodia: [Valitse]

textfile (s gs)
lineLen (s gs))
gModelR (g gs)
gBuffer (g gs)
...

En ole täysin varma, onko tekemäni muutos huononnus vai parannus lopputulokseen. Kuitenkin esimerkiksi asetusten lukeminen ja kirjoittaminen onnistuu nyt varsin yksinkertaisesti:

Koodia: [Valitse]

  -- lukeminen:
  let rname = dir ++ "/" ++ settingsFile
  oldSettings <- settingsFromFile rname
  putStrLn ("Reading " ++ rname)

  -- kirjoittaminen:
  let rname = (homeDirectory gs) ++ "/" ++ settingsFile
  writeFile rname (show (s gs))
  putStrLn ("Writing " ++ rname)

Lisäsin koodiin dialogi-ikkunat rivinpituuden, tekstitiedoston ja kirjasimen valitsemiseksi. Näistä esimerkkinä kirjasimen valinta:

Koodia: [Valitse]

openFont gsRef = do
  gs <- readIORef gsRef
  result <- chooseFont "Valitse kirjasin" (font (s gs))
  case result of
    Just newFont -> do
      writeIORef gsRef gs {
        settings = (s gs) {
          font = newFont }}
      setFonts gsRef
    otherwise -> return ()

chooseFont prompt oldFont = do
  dialog <- fontSelectionDialogNew prompt
  fontSelectionDialogSetFontName dialog oldFont
  widgetShow dialog
  response <- dialogRun dialog
  print response
  case response of
    ResponseOk -> do
      fn <- fontSelectionDialogGetFontName dialog
      widgetDestroy dialog
      return fn
    ResponseCancel -> do
      widgetDestroy dialog
      return Nothing
    ResponseDeleteEvent -> do
      widgetDestroy dialog
      return Nothing
    _ -> return Nothing

Nämä dialogi-ikkunat on yhdistetty pääohjelman valikkoon seuraavasti:

Koodia: [Valitse]

menuBarDescr =
  [("_Tiedosto",
    [("gtk-open", openFile),
     ("gtk-select-font", openFont),
     ("gtk-preferences", setPreferences),
     ("gtk-about", resultsCSV),
     ("gtk-quit", quitProgram)])
  ]

Aikaisemmin huomiotta jäänyt asia oli myös, että vanhojen tulosten sijoitukset luonnollisesti muuttuvat kun uusia syntyy:

Koodia: [Valitse]

reRank1 (Result { rDate = a, rMrks = b, rRank = c, rErrs = d }, newRank) =
  Result { rDate = a, rMrks = b, rRank = newRank, rErrs = d }

reRank rs = map reRank1 (zip rs [1..])

Lähdekoodi kokonaisuudessaan: http://personal.inet.fi/koti/jhii/asetukset-02.hs

[snifi]

Virheen sattuessa näytetään varoitusraita, jonka on tarkoitus olla visuaalisesti riittävän häiritsevä kirjoittamisen pysäyttämiseksi. Alkuperäisessä ohjelmassa käytin Gimpillä maalattua mustakeltaista PNG-kuvaa Image-komponentissa. Tällä kertaa annamme ohjelman piirtää raidat DrawingArea-komponentille. Olen tähän valinnut punaiset ja siniset raidat, mutta värejä on helppo muuttaa koodista.

Lopputulos tulee näyttämään jotakuinkin tältä:



Luonnollinen paikka piirtorutiinin käynnistämiseen on funktiossa whenBufferChanged. Tieto virheestä sisältyy gsRef-viitteeseen, joten selviämme komennolla widgetQueueDraw canvas, missä canvas on viittaus DrawingArea-komponenttiin. Se luodaan funktiossa createGUI:

Koodia: [Valitse]

  canvas <- drawingAreaNew
  widgetSetSizeRequest canvas 300 40
  onExpose canvas (
    drawCanvas gsRef canvas)
  boxPackStart outerVBox canvas PackGrow 0

Nyt siis komento widgetQueueDraw aiheuttaa funktion onExpose kutsun, joka on jaettu kahteen osaan, riippuen siitä piirretäänkö tyhjä vai näkyvä komponentti. Tyhjän komponentin piirtäminen on triviaali toimenpide, joka perustuu järjestelmän taipumukseen päivittää komponentit alkuperäisasetuksiin.

Koodia: [Valitse]

drawCanvas gsRef canvas _evt = do
  gs <- readIORef gsRef
  if (oldStatus gs) /= Error
  then drawCanvas0 canvas _evt
  else drawCanvas1 canvas _evt

drawCanvas0 canvas _evt = do
  return True

drawCanvas1 canvas _evt = do
  (w,h) <- widgetGetSize canvas
  dw <- widgetGetDrawWindow canvas
  gc1 <- gcNew dw
  gc2 <- gcNew dw
  gcSetValues gc1 newGCValues { foreground = red }
  gcSetValues gc2 newGCValues { foreground = blue }
  let c = h
      r = 15
      limit0 = -1 - c `div` r
      limit1 = (w+c) `div` r + 1
  mapM
    ( \(points,gc) -> drawPolygon dw gc True points)
    [([(x*r+c,0),(x*r,h),((x+1)*r,h),((x+1)*r+c,0)],
     if x `mod` 2 == 0 then gc1 else gc2)  | x <- [limit0..limit1]]
  return True

Piirtorutiinit, kuten tavallisesti, menevät minulla lukukelvottomaksi sekasotkuksi, mutta ajatus on siinä, että vuorotellaan grafiikkakonteksteja gc1 ja gc2, jotka tässä ovat punainen ja sininen kynä. Kukin raita on monikulmio (drawPolygon), jonka alakoordinaattien x-arvot poikkeavat vakion c verran yläkoordinaateista, aiheuttaen monikulmion kallistumisen. Vakio r määrää yhden raidan leveyden pikseleinä.

Punainen ja sininen väri ovat red ja blue, jotka olen määritellyt seuraavasti:

Koodia: [Valitse]

color r g b = Color (r*256) (g*256) (b*256)
green  = color 115 210 22
red    = color 255 51 102
blue   = color 51 102 255
yellow = color 252 233 79

Kun erilaisia värejä on nyt koko joukko määriteltynä, voimme tehdä niiden avulla vaikkapa pienen väriefektin Tietoja-valikon tulostietodialogiin. Se värittää tekstirivin vihreäksi kun CSV-muotoinen tulosluettelo tallennetaan. Label-komponentti ei sisällä tietoa taustaväristä, joten upotamme sen EventBox-komponenttiin, ja muutamme sen taustavärin vihreäksi:

Koodia: [Valitse]

onSaveClicked fname text label = do
  writeFile fname text
  labelSetText label ("Kirjoitettiin " ++ fname)
  parent <- widgetGetParent label
  case parent of
    Nothing -> print "No parent"
    Just parent -> widgetModifyBg parent StateNormal (green)
  return ()

Yksi tärkeä muutos ohjelmaan on varautua virheisiin tekstitiedostoa luettaessa, esimerkiksi tiedoston puuttumiseen aloitettaessa. Tämän vuoksi sisällytämme readFile-käskyn try-rakenteeseen, samaan tapaan kuin aikaisemmin tuloksia ja asetuksia luettaessa. Tiedoston luvun epäonnistuessa näytämme yksinkertaisen virhedialogin ja palautamme epämääräisen joukon valmiiksi määriteltyjä latinankielisiä sananlaskuja (ei kuvassa).

Koodia: [Valitse]

tryReadFile fname = do
  opResult <- try ( do
    text <- readFile fname
    return text)
  case opResult of
    Left excp -> return (
      (unlines proverbs),
      Just ("Tiedostoa " ++ fname ++ " ei voitu lukea."))
    Right text -> return (text, Nothing)

showErrorDialog txt gsRef = do
  gs <- readIORef gsRef
  let parent = Just (gWindow (g gs))
  dialog <- messageDialogNew parent [] MessageWarning ButtonsOk "Avaa tiedosto"
  messageDialogSetSecondaryText dialog txt
  dialogRun dialog
  widgetDestroy dialog

getLines gsRef = do
  gs <- readIORef gsRef
  (originalText, err) <- tryReadFile (textfile (s gs))
  ...
  case err of
    Nothing -> return ()
    Just txt -> showErrorDialog txt gsRef

Ohjelmakoodi kokonaisuudessaan: http://personal.inet.fi/koti/jhii/varoitusraidat.hs


Tässä vielä hieman ohjeita ohjelman kääntämiseksi GHC-kääntäjällä.

Tulkattavassa muodossa ohjelma käynnistettiin komennolla

Koodia: [Valitse]

runhaskell varoitusraidat.hs

Nimetään ensin lähdetiedosto hieman asiallisemmin:

Koodia: [Valitse]

mv varoitusraidat.hs hatupist.hs

Yksinkertainen käännösprosessi tuottaa valtaisan 18 megatavun tiedoston:

Koodia: [Valitse]

$ ghc hatupist.hs
[1 of 1] Compiling Main             ( hatupist.hs, hatupist.o )
Linking hatupist ...
$ ll hatupist
-rwxrwxr-x. 17996645 29.7. 22:09 hatupist

Tässä kaikki GTK-kirjastot on linkitettynä ohjelmaan. Voimme jättää ne pois kääntämällä ohjelma komennolla ghc -O2 -dynamic (Valitsin on O-kirjain, ei nolla), jolloin päädymme alle neljäsataakiloiseen ohjelmaan.

Koodia: [Valitse]

$  ghc -O2 -dynamic hatupist.hs
[1 of 1] Compiling Main             ( hatupist.hs, hatupist.o )
Linking hatupist ...
$ ll hatupist
-rwxrwxr-x. 357132 29.7. 22:15 hatupist

Komennolla strip ohjelmasta saa vieläkin ylimääräistä pois:

Koodia: [Valitse]

$ strip hatupist
$ ll hatupist
-rwxrwxr-x. 239176 29.7. 22:18 hatupist
$ rm hatupist.hi hatupist.o
$ ./hatupist


[snifi]

Niitä varten, jotka eivät vielä osaa kymmensormijärjestelmää, saattaisi olla hyvä laatia jonkinlainen avustava näppäimistönkuva, josta näkisi näppäimen sijainnin, mikäli ei satu sitä muistamaan. Päädyin tekemään tämän osan erillään varsinaisesta ohjelmasta, sillä en vielä tiedä, minkä verran komponentti tulee vaatimaan esimerkiksi mahdollisuutta muokata asetuksia, kuten käytettävää näppäimistökarttaa.

Komponentti näyttää tältä:
 


Siinä on eroteltuna sormien alueet omilla väreillään, ja vuorossa oleva A-kirjain on korostettu negatiivisella taustalla.

Näppäimistökartoista DAS ja QWERTY on valmiiksi määriteltyjä:

Koodia: [Valitse]

das = [
  "phrkz'wuybq",
  "slntvgaioec",
  "fxdmjåöä,.-"]

qwerty = [
  "qwertyuiopå",
  "asdfghjklöä",
  " zxcvbnm,.-"]

Eri väreillä tulevat alueet on määritelty qwertyn avulla.

Koodia: [Valitse]

qwertyAreas = ["rfvujm", "edcik,", "wsxol.", "qazpö-"]
areaColors  = [blue, green, red, yellow]

Nyt siis paikassa (x,y) olevan näppäimen "qwertyarvo" ja sitä vastaava väri saadaan funktioista

Koodia: [Valitse]

qwertyColor letter =
  if null as then Nothing else Just (areaColors !! (head as))
  where
    as = [a |(a,i) <- zip [0..] qwertyAreas, letter `elem` i]

qwertyLetter x y =
  if y < length qwerty && x < length (qwerty!!y)
    then (qwerty !! y) !! x
    else ' '

Piirtoalueena on jälleen DrawingArea-komponentti. Sen koko on 275x78 pikseliä, ja onExpose-tapahtumankäsittelijä huolehtii alueen uudelleenpiirrosta kutsumalla myöhemmin määrittelemäämme funktiota drawCanvas.

Koodia: [Valitse]

  canvas <- drawingAreaNew
  widgetSetSizeRequest canvas 275 78
  onExpose canvas (
    drawCanvas canvas gsRef)
  boxPackStart vbox canvas PackGrow 0

Taustavärit piirretään täytettyinä suorakulmioina funktiossa drawBottom. Niitä varten luodaan uusi piirtokonteksti gc, jonka väri saa parametrin c arvon.

Koodia: [Valitse]

drawBottom dw xx yy r c = do
  gc <- gcNew dw
  gcSetValues gc newGCValues { foreground = c }
  drawRectangle dw gc True xx yy r r

Yksittäinen näppäin piirretään funktiossa drawKey. Sille välitetään piirtokontekstit gc1 ja gc2, joista ensimmäinen on normaalivärein piirrettävä näppäin ja toinen on negatiivisin värein piirrettävä näppäin. GTK-kirjaston asemointimäärittelyt huolehtivat kirjaimen keskittämisestä laatikkoonsa. Laatikon sivun pituus on r1 = 20 ja ympäröivä tila mukaanlukien r2 = 23. Jokaisen rivin yksilöllinen etäisyys vasemmasta laidasta on kerrottuna taulukossa deltaX = [3,12,0].

Koodia: [Valitse]

drawKey canvas dw gc1 gc2 x y letter selected = do
  let co = qwertyColor(qwertyLetter x y)
      gc = if selected then gc2 else gc1
  case co of
    Just c  -> drawBottom dw (zentr xx) (zentr yy) r2 c
    Nothing -> return ()
  when selected (drawRectangle dw gc1 True xx yy r1 r1)
  drawRectangle dw gc False xx yy r1 r1
  layout <- widgetCreateLayout canvas letter
  layoutSetAlignment layout AlignCenter
  layoutSetWidth layout (Just (fromIntegral r1))
  drawLayout dw gc xx (yy+3) layout
  where
    r1 = 20
    r2 = 23
    zentr z = z - (r2-r1) `div` 2
    deltaXs = [3,12,0]
    margin = 5
    xx = x*r2+deltaXs!!y + margin
    yy = y*r2     

Olen oheisessa ohjelmassa tuttuun tapaan käyttänyt viittausta globaaliin muuttujarakenteeseen gsRef välittämään valittuna olevan näppäimen tiedot ajastimelta piirtorutiineille. Tällä kertaa gsRef sisältää ainoastaan parin, jonka ensimmäinen alkio on ajastimeen liittyvä järjestysluku ja toinen alkio valittuna oleva kirjain annetusta merkkijonosta text.

Koodia: [Valitse]

onTimeout canvas gsRef = do
  (i,c) <- readIORef gsRef
  widgetQueueDraw canvas
  let j = (i+1) `mod` (length text)
  writeIORef gsRef (j, text!!j)
  return True

Ohjelmakoodi: http://personal.inet.fi/koti/jhii/avustaja-02.hs

[snifi]

Tämänkertaiseen versioon olen lisännyt ikkunan alalaitaan tilarivin. Se on Label-komponentti, joka on upotettu EventBox-komponenttiin, jotta sen taustaväriä voidaan muuttaa. Toiminnaltaan se vastaa aikaisemmin dialogi-ikkunaan tekemäämme ilmoitusriviä. Tilarivin teksti ja väri muutetaan ohjelmassa määritellyllä funktiolla setStatusText text color gs, jossa ensimmäinen parametri on näytettävä teksti tyyliin "Voit aloittaa.", "Korjaa virheet!", tms. ja toinen parametri on taustaväri, esimerkiksi green tai red, jotka määrittelimme aikaisemmin. Taustaväri jätetään huomiotta jos teksti on tyhjä merkkijono "", jolloin käytetään komponentin oletustyyliä. Oletustyyli otettiin talteen ikkunaa luodessa komennolla style  <- widgetGetStyle window, ja se sijaitsee globaalimuuttujan gs kentässä gStyle gui.

Tilarivin lisäksi aloin kaipaamaan ohjelmaan jonkinlaista visuaalista ilmaisinta aina kun kolmenkymmenen sekunnin jaksot kuluvat umpeen ja uudet tulokset päivitetään. Tähän tarkoitukseen luomme uuden piirtoalueen tulostaulujen vasemman palstan alle:

Koodia: [Valitse]

  timingCanvas <- drawingAreaNew
  widgetSetSizeRequest timingCanvas 300 3
  onExpose timingCanvas (
    drawTimingCanvas gsRef timingCanvas)
  boxPackStart innerVBox1 timingCanvas PackGrow 0

Se on käytännössä kapea kolmen pikselin väriviiva, joka silloin tällöin ilmestyy ruudulle. Tämä piirtoalue päivitetään jota kuinkin samaan tapaan kuin aikaisemmin piirrettiin virheilmaisimen varoitusraidoitus. Piirtoalueen tyhjentämiseen ne molemmat käyttävät määrittelemäämme funktiota drawEmptyPicture canvas.

Funktiot, jotka päättävät piirretäänkö kuva vai tyhjä tausta, ovat nimeltään drawErrorCanvas (virheilmaisimen tapauksessa) ja drawTimingCanvas (tulospäivityksen tapauksessa). Tulospäivitys käyttää globaalia muuttujaa showTimingPict, joka saa arvon True kun tulostaulujen sisältöä muutetaan, sekä arvon False päivitystarpeen poistuessa kun kuva on piirretty. Kun kuva piirretään, käynnistetään samalla ajastin timeoutAdd (onTimeToClear canvas) 1000, joka sekunnin kuluttua poistaa kuvan ruudulta.

Kuvan piirtoon liittyvät rutiinit ovat funktioissa drawErrorPicture (varoitusraidat) ja drawTimingPicture (tulospäivitys). Näistä jälkimmäinen seuraavassa:

Koodia: [Valitse]

drawTimingPicture gs canvas = do
  row <- listStoreGetValue (gModelR (g gs)) 2
  (w,h) <- widgetGetSize canvas
  dw <- widgetGetDrawWindow canvas
  gc1 <- gcNew dw
  let r = rRank row
      k = (d-1) `min` floorLogBase 3 (r+1)
  gcSetValues gc1 newGCValues { foreground = colors !! k }
  drawRectangle dw gc1 True 0 0 w h
  timeoutAdd (onTimeToClear canvas) 1000
  return True
  where
    colors = [grtd0, grtd1, grtd2, grtd3, grtd4, grtd5, grtd6]
    d = length colors

floorLogBase :: Int -> Int -> Int
floorLogBase base n =
  floor (logBase (fromIntegral base) (fromIntegral n))

Piirtoalueelle ilmestyvä kapea suorakulmio väritetään tässä siis eri värillä sen mukaan miten hyvä tulos sattui olemaan. Asteikko on logaritminen ja heikoimmat tulokset pakotetaan viimeisen värin alueelle. Lopputulos ei välttämättä olisi ollut näin pitkän koodin arvoinen, ehkä löydämme myöhemmin paremman tavan hoitaa asia.

Ohjelmakoodi kokonaisuudessaan: http://personal.inet.fi/koti/jhii/tilarivi.hs