Do vosso colega, thoga31

{$mode objfpc}
program xmas_newyear_2013;
uses types, crt,
     XmasTree, LetrasBonitas;
 
var Arvore : TTree;
    key : char;
    n2, n0, n1, n3 : TLetra;
    F, E, L, I, Z, N, A, T : TLetra;
    contador : integer = 0;  // Controla mudança de texto
    Natal : boolean = true;  // Controla que texto é escrito
 
const InitPos : TPoint = (x:3; y:4);  // Posição da árvore
      WaitTime = 300;  // Tempo de espera para actualizar todo o GUI
      MaxCont = 5000;  // Tempo necessário para mudar de texto (pode ser excedido) (em milissegundos)
      PosLetras = 3;   // Posição das letras do texto (eixo yy)
 
 
procedure CarregarGUI;
(* Prepara todas as letras necessárias *)
begin
    PreencherLetra(n0, '0');
    PreencherLetra(n1, '1');
    PreencherLetra(n2, '2');
    PreencherLetra(n3, '3');
 
    PreencherLetra(F, 'F');
    PreencherLetra(E, 'E');
    PreencherLetra(L, 'L');
    PreencherLetra(I, 'I');
    PreencherLetra(Z, 'Z');
    PreencherLetra(N, 'N');
    PreencherLetra(A, 'A');
    PreencherLetra(T, 'T');
end;
 
procedure DesenharGUI;
(* Desenha o GUI inicial *)
begin
    TextColor(15);
    write('A todos os utilizadores do P@P, desejo um...');
 
    TextColor(15);
    DesenharLetra(F, 16, PosLetras);
    DesenharLetra(E, 22, PosLetras);
    DesenharLetra(L, 28, PosLetras);
    DesenharLetra(I, 34, PosLetras);
    DesenharLetra(Z, 40, PosLetras);
 
    TextColor(14);
    DesenharLetra(N, 50, PosLetras);
    DesenharLetra(A, 56, PosLetras);
    DesenharLetra(T, 62, PosLetras);
    DesenharLetra(A, 68, PosLetras);
    DesenharLetra(L, 74, PosLetras);
end;
 
procedure MudarGUI(const Xmas : boolean);
(* Muda o texto - "Xmas" indica se será escrito "Natal" ou "2013" *)
var elem : integer;
begin
    for elem in [50, 56, 62, 68, 74] do ApagarLetra(elem, PosLetras);
 
    TextColor(14);
    if Xmas then begin
        DesenharLetra(N, 50, PosLetras);
        DesenharLetra(A, 56, PosLetras);
        DesenharLetra(T, 62, PosLetras);
        DesenharLetra(A, 68, PosLetras);
        DesenharLetra(L, 74, PosLetras);
    end else begin
        DesenharLetra(n2, 50, PosLetras);
        DesenharLetra(n0, 56, PosLetras);
        DesenharLetra(n1, 62, PosLetras);
        DesenharLetra(n3, 68, PosLetras);
    end;
end;
 
begin (* BLOCO PRINCIPAL *)
    CarregarGUI;
    DesenharGUI;
 
    Arvore := TTree.Create(8, 2, InitPos, 0);
    Arvore.Draw;
    repeat
        while not keypressed do begin
            Arvore.ShinyLights;
            GotoXY(80, 25);
            delay(WaitTime);
            Inc(contador, WaitTime);
            if contador >= MaxCont then begin
                Natal := not Natal;
                MudarGUI(Natal);
                contador := 0;
            end;
        end;
        key := readkey;
    until key = #13;
    Arvore.Free;
end.

{$MODE DELPHI}
unit LetrasBonitas;
 
interface
uses crt;
type TLetraPreenchimento = (Cheio, Medio, Nada); // #219, #177, #32
     TLetra = array [1..5, 1..7] of TLetraPreenchimento; // [x, y]
 
procedure DesenharLetra(const Letra : TLetra; const PosX, PosY : word);
procedure PreencherLetra(var Letra : TLetra; const Caracter : char);
procedure ApagarLetra(const PosX, PosY : word);
 
 
implementation
 
procedure DesenharLetra(const Letra : TLetra; const PosX, PosY : word);
(* Realiza o output de uma 'TLetra' *)
 
   function LetraPreench2Char(const Preenchimento : TLetraPreenchimento) : char;
   (* Converte um 'TLetraPreenchimento' no seu respectivo 'Char' *)
   begin
        case Preenchimento of
             Cheio : result := #219;
             Medio : result := #177;
             Nada  : result := #32;
        end;
   end;
 
var x : 1..5; // TLetra[x, y]
    y : 1..7;
 
begin
     for y := 1 to 7 do begin
         GotoXY(PosX, PosY + y - 1); // coloca na linha seguinte, mantendo o alinhamento
         for x := 1 to 5 do write(LetraPreench2Char(Letra[x, y])); // Output auxiliado
     end;
end;
 
 
procedure ApagarLetra(const PosX, PosY : word);
var x : 1..5;
    y : 1..7;
begin
    TextBackGround(0);
    for y := 1 to 7 do begin
        GotoXY(PosX, PosY + y - 1);
        for x := 1 to 5 do write(' ');
    end;
end;
 
 
procedure PreencherLetra(var Letra : TLetra; const Caracter : char);
(* Inicializa a letra - recebe por referência a 'TLetra' e recebe qual o 'Caracter' como deve ser carregado *)
var x : 1..5; // Letra[x, y]
    y : 1..7;
    Caract : char; // Fica com o Upper Case de 'Caracter'
begin
     Caract := UpCase(Caracter);
 
     for x := 1 to 5 do
         for y := 1 to 7 do Letra[x, y] := Nada; // Faz reset à Letra
 
     case Caract of
          '0' : begin
                     for x := 1 to 5 do begin
                         Letra[x, 1] := Cheio;
                         Letra[x, 7] := Cheio;
                     end;
                     for y := 2 to 6 do begin
                         Letra[1, y] := Cheio;
                         Letra[5, y] := Cheio;
                     end;
                end;
 
          '1' : begin
                     for y := 1 to 7 do Letra[5, y] := Cheio;
                     Letra[4, 1] := Cheio;
                end;
 
          '2' : begin
                     for x := 1 to 5 do begin
                         Letra[x, 1] := Cheio;
                         Letra[x, 4] := Cheio;
                         Letra[x, 7] := Cheio;
                     end;
                     for y := 2 to 3 do Letra[5, y] := Cheio;
                     for y := 5 to 6 do Letra[1, y] := Cheio;
                end;
 
          '3' : begin
                     for x := 1 to 5 do begin
                         Letra[x, 1] := Cheio;
                         Letra[x, 4] := Cheio;
                         Letra[x, 7] := Cheio;
                     end;
                     for y := 2 to 3 do Letra[5, y] := Cheio;
                     for y := 5 to 6 do Letra[5, y] := Cheio;
                end;
 
          'F' : begin
                     for y := 1 to 7 do Letra[1, y] := Cheio;
                     for x := 2 to 5 do Letra[x, 1] := Cheio;
                     for x := 2 to 3 do Letra[x, 4] := Cheio;
                end;
 
          'E' : begin
                     PreencherLetra(Letra, 'F');
                     for x := 2 to 5 do Letra[x, 7] := Cheio;
                end;
 
          'L' : begin
                     for y := 1 to 7 do Letra[1, y] := Cheio;
                     for x := 2 to 5 do Letra[x, 7] := Cheio;
                end;
 
          'I' : begin
                     for y := 2 to 6 do Letra[3, y] := Cheio;
                     for x := 2 to 4 do begin
                         Letra[x, 1] := Cheio;
                         Letra[x, 7] := Cheio;
                     end;
                end;
 
          'Z' : begin
                     for x := 1 to 5 do begin
                         Letra[x, 1] := Cheio;
                         Letra[x, 7] := Cheio;
                     end;
                     Letra[5, 2] := Cheio;
                     Letra[1, 6] := Cheio;
                     Letra[4, 3] := Cheio;
                     Letra[2, 5] := Cheio;
                     Letra[3, 4] := Cheio;
                end;
 
          'N' : begin
                     for y := 1 to 7 do Letra[1, y] := Cheio;
                     for y := 1 to 7 do Letra[5, y] := Cheio;
                     Letra[2, 1] := Cheio;
                     Letra[2, 2] := Cheio;
                     Letra[3, 3] := Cheio;
                     Letra[3, 4] := Cheio;
                     Letra[3, 5] := Cheio;
                     Letra[4, 6] := Cheio;
                     Letra[4, 7] := Cheio;
                end;
 
          'A' : begin
                     for x := 2 to 4 do Letra[x, 1] := Cheio;
                     for x := 2 to 4 do Letra[x, 4] := Cheio;
                     for y := 1 to 7 do Letra[1, y] := Cheio;
                     for y := 1 to 7 do Letra[5, y] := Cheio;
                end;
 
          'T' : begin
                     for x := 1 to 5 do Letra[x, 1] := Cheio;
                     for y := 2 to 7 do Letra[3, y] := Cheio;
                end;
     end;
end;
 
end.

{$mode objfpc}
unit XmasTree;
(* Desenha uma árvore de Natal simples, com "luzes" *)
 
interface
uses types, crt;
 
type TTree = class(TObject)
     public
        type TTransp = 0..3;  // Transparência da árvore - não recomendado utilizar pois não está preparado devidamente com as luzes em termos gráficos.
        procedure Draw;
        procedure ShinyLights;
        constructor Create(height, scale : word; position : TPoint; transparency : TTransp);
 
     private
        procedure CreateLights;
        const NLights = 30;  // Número de luzes - podem-se sobrepor
        type TLights = array[1..NLights] of TPoint;  // posição das luzes
        var VHeight : word;  // altura
            VScale : word;   // escala - a altura final da árvore será VHeight*VScale
            VTransparency : TTransp;
            VLights : TLights;
            VLightsState : boolean;  // Luzes ligadas ou desligadas
            VPosition : TPoint;  // Posição da árvore
            c : char;  // Caracter que compõe o desenho da árvore - depende da transparência
     end;
 
 
implementation
 
constructor TTree.Create(height, scale : word; position : TPoint; transparency : TTransp);
(* Cria a árvore, mas não a desenha - apenas inicializa uma instância *)
begin
    self.VHeight := height;
    self.VScale := scale;
    self.VTransparency := transparency;
    self.VPosition := position;
 
    self.C := char(179 - transparency);  // define o caracter em função da transparência
    if self.C = #179 then self.C := #219;
 
    self.VLightsState := false;
    self.CreateLights;  // Gera a posição das luzes
end;
 
procedure TTree.Draw;
(* Desenha a árvore - explicação dos cálculos excluída *)
var i, j : word;
begin
    TextColor(2);
    for i := 0 to self.VHeight * self.VScale - 1 do begin
        GotoXY(self.VPosition.x + self.VHeight - i div self.VScale - 1, self.VPosition.y + i);
        for j := 1 to 2 * (i div self.VScale) + 1 do
            Write(self.c);
    end;
 
    TextColor(6);
    for i := 0 to 2 do begin
        GotoXY(self.VPosition.x + self.VHeight - 2, self.VPosition.y + self.VHeight * self.VScale + i);
        Write(self.c, self.c, self.c);
    end;
 
    TextColor(7);
end;
 
procedure TTree.CreateLights;
(* Gera aleatoriamente a posição das luzes - não calcula os pontos em função da posição *)
var i : integer;
begin
    randomize;
    for i:=1 to self.NLights do begin
        self.VLights[i].y := Random(self.VHeight * self.VScale);
        self.VLights[i].x := self.VHeight - (self.VLights[i].y div self.VScale) + Random(2 * (self.VLights[i].y div self.VScale) - 1);
    end;
end;
 
procedure TTree.ShinyLights;
(* Actualiza as luzes de forma aleatória - liga ou desliga? *)
var i : integer;
    ch : char;
begin
    randomize;
    if random(2) = 1 then begin
        self.VLightsState := not self.VLightsState;
        if self.VLightsState then begin
            ch := #254;
            TextColor(12);
            TextBackGround(2);
        end else begin
            ch := self.c;
            TextColor(2);
            TextBackGround(0);
        end;
        for i:=1 to self.NLights do begin
            GotoXY(self.VLights[i].x + self.VPosition.x - 1, self.VLights[i].y + self.VPosition.y);
            write(ch);
        end;
    end;
end;
 
end.