Cu formulările structurale din [1], obţineam în serie un număr destul de mare de orare (chiar şi 1000) pentru lecţiile unei zile – constatând astfel ce aşteptări putem avea de la programul respectiv, pentru diverse ordonări iniţiale a listei profesorilor (cam în cât timp s-ar genera un orar şi cam câte ferestre are acesta). Acum vom compacta cumva lucrurile (mai realist şi poate, „mai bine”), formulând un program care să producă un orar al lecţiilor unei zile (ţinând seama de constatările făcute anterior):

# daySchoolSchedule.R
library(tidyverse)
CSVname <- "perDiem/day3Lessons.CSV"

În variabila CSVname trebuie înscris numele unuia dintre fişierele CSV în care sunt prevăzute lecţiile (dintr-un acelaşi schimb) corespunzătoare câte uneia dintre zilele săptămânii, sub forma prof, clase – de exemplu:

prof,clase  # antetul fişierului CSV
P01, 10D 11A 8C 6A 8A 8B
P08, 12C 12D 5C 6D  # 'P08' are 4 lecţii în ziua respectivă, anume la clasele ...

Transformăm fişierul indicat, într-un tabel (obiect tibble) al tuturor lecţiilor zilei:

lessons <- read_csv(CSVname, col_types = "cc") %>%
           mutate(ncl = unlist(
                  lapply(.$clase, function(q) length(strsplit(q, " ")))
           )) %>%
           uncount(.$ncl) %>% 
           split(., .$clase) %>%
           map_df(., function(G) 
                  tibble(prof = G$prof, 
                         cls = unlist(strsplit(G$clase[1], " ")))
           ) %>% arrange(prof, cls)

> lessons
# A tibble: 241 x 2  (241 lecţii)
   prof  cls  
   <chr> <chr>
 1 P01   10D  
 2 P01   11A  
 3 P01   6A   
 4 P01   8A   
 5 P01   8B   
 6 P01   8C   
 7 P02   6C   
 8 P02   6E   
 9 P02   7C   
10 P02   9B   
# … with 231 more rows

Este drept că în [1] aveam (ceea ce este „mai bine”) o funcţie "csv2tidy()" care primind fişierul lecţiilor zilei, returna obiectul 'tibble' obţinut (direct) mai sus…

În urma constatărilor făcute în [1], decidem să acceptăm orarul produs dacă numărul de ferestre nu depăşeşte 15% din totalul lecţiilor:

nGaps <- nrow(lessons) %/% 100 *15

Pentru numărul ferestrelor din orar instituisem în [1] funcţia „ajutătoare” holes(), dar cu o formulare vulgară – pe 14 linii de cod, cu trei cicluri for(); rescriem astfel:

holes <- function(v) {  # Numărul de ferestre (biţi '0' între biţi '1')
    bts <- which(bitwAnd(v, c(1, 2, 4, 8, 16, 32, 64)) > 0)
    n <- length(bts)
    bts[n] - bts[1] + 1 - n
}

Dacă cele 4 lecţii ale profesorului "P02" sunt alocate să zicem, în orele 2, 4, 5 şi 7 ale zilei, atunci lui "P02" îi asociem valoarea 2¹+2³+2⁴+2⁵=90 (ora h=1..7 a zilei corespunde bitului de rang (h-1)); holes(90) ne dă numărul de biţi '0' aflaţi între primul şi ultimul '1' din octetul respectiv – deci numărul de ferestre ale lui 'P02'.

Vom impune orarului produs condiţia ca fiecare profesor să aibă cel mult două ferestre; renunţăm din considerente practice, la condiţia suplimentară din [1], ca (dacă există) ferestrele profesorului să fie consecutive (apreciem că în final, situaţiile de ferestre ne-consecutive sunt mai uşor de „reparat”!).

Pentru lista profesorilor, am constatat în [1]-4 că (pentru programul nostru de generare a orarului zilei) ordinea cea mai bună este dată de coeficienţii "betweenness" dintr-un anumit graf asociat profesorilor (pachetul igraph trebuie să fie deja instalat):

profs <- lessons %>% distinct(.$prof) %>% pull()  # şirul numelor profesorilor
np <- length(profs)
adjm <- matrix(rep(0, np), nrow=np, ncol=np, byrow=TRUE, 
               dimnames=list(profs, profs))  # matrice de adiacenţă

cls_of <- function(P) {  # şirul claselor profesorului dat
    lessons %>% filter(prof==P) %>% 
    distinct(cls) %>% pull()
}
adj_of <- function(P) {  # profesorii adiacenţi unuia dat
    lessons %>% filter(prof != P & cls %in% cls_of(P)) %>% 
    distinct(prof) %>% pull()
}
for(P1 in profs)
    for(P2 in adj_of(P1))
        adjm[P1, P2] <- 1  # adiacenţi dacă au măcar o clasă comună

BTW <- igraph::graph_from_adjacency_matrix(adjm, mode="undirected") %>%
       igraph::betweenness(., directed=FALSE) %>%
       sort()

Sarcina programului nostru este aceea de a aloca lecţiile pe orele 1..7 ale zilei, fără suprapuneri şi astfel încât numărul total de ferestre să nu depăşească valoarea fixată în nGaps. Este esenţial ca profesorii să apară într-o anumită ordine, păstrând-o apoi pentru lista lecţiilor fiecărei clase; asociem profesorilor un vector de întregi, pentru a urmări alocările făcute lecţiilor acestora, precum şi ferestrele apărute la fiecare:

task <- lessons %>%
        mutate(prof = factor(prof, 
                             levels = names(BTW), ordered = TRUE)) %>%
        arrange(prof, cls)
hBits <- rep(0L, nlevels(task$prof))  # alocările de ore (biţi) la profesori
names(hBits) <- levels(task$prof)

O clasă are în ziua respectivă ko=4..7 ore, iar alocarea lecţiilor ei pe orele zilei revine la a adăuga în tabelul lecţiilor respective o coloană conţinând o anumită permutare a valorilor 1..ko; în fişierul constituit anterior "lstPerm47.RDS" avem o listă cu 4 componente, fiecare fiind o matrice ale cărei coloane sunt permutările de 1..ko:

Pore <- readRDS("lstPerm47.RDS")  # lista matricelor de permutări (de 4..7 ore)

Funcţia următoare montează (dacă se poate) o coloană '$ora' pe tabelul lecţiilor unei clase, conţinând prima permutare 1..ko din matricea corespunzătoare de permutări, pentru care se constată că nu intră în conflict cu alocarea făcută anterior unei alte clase (adică nu există un profesor comun celor două clase, căruia să-i fie alocată pe ambele orare ale claselor, o aceeaşi oră din zi) şi în plus, nu conţine mai mult de două ferestre:

mountHtoCls <- function(Q) {    # alocă pe 1..7, lecţiile unei clase
    mpr <- Pore[[nrow(Q)-3]]  # matricea de permutări corespunzătoare clasei
    bhp <- bith[Q$prof]  # biţii alocaţi anterior, profesorilor clasei
    flag <- FALSE
    for(i in 1:ncol(mpr)) { 
        po <- mpr[, i]
        bis <- bitwShiftL(1, po - 1)
        if(any(bitwAnd(bhp, bis) > 0)) 
            next  # caută o permutare care să evite biţi '1' alocaţi deja 
        # Dacă un profesor are 2 sau mai multe ore pe zi la aceeaşi clasă:
        if(anyDuplicated(bhp) > 0) {
            for(jn in 1:(nrow(Q)-1)) {
                if(names(bhp)[jn] == names(bhp)[jn+1]) 
                    bis[jn] <- bis[jn+1] <- bis[jn] + bis[jn+1]
            }
        }  # se poate comenta, dacă NU există profesor cu 2 ore la clasă 
        blks <- bitwOr(bhp, bis)  # cumulează biţii vechilor şi noii alocări
        Cond1 <- unlist(lapply(blks, holes))
        if(any(Cond1 > 2)) next  # controlează numărul de ferestre
        bith[Q$prof] <<- blks  # actualizează vectorul global al octeţilor de alocare
        return(Q %>% mutate(ora = po))  # înscrie orarul clasei curente
    }
    return(NULL)  # dacă pentru clasa curentă NU s-a reuşit un orar "bun"
} 

Din setul tuturor lecţiilor, formăm (prin split()) o listă în care fiecare componentă conţine lecţiile câte uneia dintre clase; în mod implicit, coloanele $prof din subseturile corespunzătoare claselor păstrează atributele de "factor" (nivelele şi ordinea acestora) ale coloanei comune din care provin.
Apoi, dispunem aleatoriu numele claselor şi în ordinea respectivă, aplicăm mountHtoCls() câte unui subset de lecţii; dacă pentru clasa curentă, mountHtoCls() returnează NULL (negăsind o permutare de 1..ko care să evite suprapunerile cu alocări făcute anterior unor alte clase şi care în plus, să nu producă mai mult de două ferestre) – atunci abandonăm parcurgerea în continuare a claselor în ordinea stabilită şi… o luăm de la capăt: reordonăm aleatoriu lista numelor claselor, reiniţializăm octeţii de alocare asociaţi profesorilor şi reluăm parcurgerea claselor în noua ordine; de fiecare dată când mountHtoCls() reuşeşte să monteze coloana $ora, salvăm orarul constituit astfel pentru clasa curentă, într-o listă "odf" având drept chei numele claselor:

Z <- task %>% split(.$cls)  # desparte lecţiile după clasă
odf <- vector("list", length(names(Z)))  # va înregistra orarele claselor
while(TRUE) {
    succ <- TRUE
    bith <- hBits  # reiniţializează octeţii de alocare pe orele zilei
    lstCls <- sample(names(Z))
    for(K in lstCls) {  # parcuge clasele în ordine aleatorie
        W <- mountHtoCls(Z[[K]])  # încearcă un orar pentru clasa curentă
        if(is.null(W)) {
            succ <- FALSE 
            break  # abandonează în caz de insucces
        }
        odf[[K]] <- W  # salvează orarul constituit clasei curente
    }
    if(succ & sum(unlist(lapply(bith, holes))) <= nGaps) break
}

În final, combinăm (prin dplyr::bind_rows()) orarele înscrise în lista "odf" şi eventual, salvăm tabelul rezultat şi vectorul octeţilor de alocare:

orar <- bind_rows(odf)
save(orar, bith, file="orar.Rdata")  # prof|cls|ora şi biţii profesorilor

Desigur, vom putea constata imediat câte ferestre are orarul obţinut:

> sum(unlist(lapply(bith, holes)))

iar dacă vrem neapărat un orar cu şi mai puţine ferestre, atunci n-avem decât să relansăm programul:

> source("daySchoolSchedule.R")

Fiindcă programul include anumite aspecte aleatorii, putem obţine un orar (cu un număr cât se poate de mic de ferestre) în 3-4 minute dacă avem noroc, sau în general în 10-15 minute, sau dacă nu avem noroc, în 30-70 minute – cum am constatat în experimentele noastre, pentru 241 de lecţii cu 68 de profesori la 40 de clase (bineînţeles că aceste aprecieri de durată variază de la caz la caz după numărul de lecţii, profesori şi clase, depinzând nu doar de „noroc”).

Iar prin funcţia orarByProf() din [1], putem obţine şi un fişier CSV corespunzător orarului rezultat – fişier care poate fi utilizat apoi într-o aplicaţie interactivă (v. /dayRecast şi /recast) prin care să reducem numărul de ferestre şi să retuşăm poziţia acestora; desigur, apelăm la interactivitate câtă vreme încă nu reuşim un program suplimentar care să cizeleze automat orarul respectiv…