Cod sursa(job #479875)

Utilizator cont_de_testeCont Teste cont_de_teste Data 25 august 2010 15:24:01
Problema Sum Scor 85
Compilator fpc Status done
Runda Arhiva de probleme Marime 4.13 kb
const base = 1000000000 ;
      nbase = 9 ;

type vec = string [255] ;
     vec1 = array[0 .. 25] of longint ;

var N, j, i, k, l, y : longint ;
    v : array[1 .. 100000] of longint ;
    f, g : text ;
    x : vec ;


    procedure fisier;
        begin
            assign ( f,'sum.in' ) ; reset ( f ) ;
            assign ( g,'sum.out') ; rewrite ( g ) ;
        end;

    procedure atr ( var A : vec1; X : longint ) ; // A <- X
    begin
        A[0] := 0;
        while ( X <> 0 ) do
            begin
                inc ( A[0] );
                A[A[0]] := X mod base;
                X := X div base;
            end;
    end;

    procedure mul ( var A : vec1 ; B : longint ) ;  // A <- A * B
    var i : longint;
        t : int64 ;

    begin
        t := 0; i := 1;

        while ( i <= A[0] ) or ( t <> 0 ) do
            begin
                if ( i > A[0] ) then
                    A[i] := 0;

                t := t + int64 ( A[i] ) * int64 ( B );
                A[i] := t mod base;
                t := t div base;
                inc ( i ) ;
            end;

       A[0] := i - 1;
    end;

    procedure scrie ( A : vec1 ) ;
    var i, j, p, t : longint;

    begin
        write ( g, A[A[0]] ) ;
        for i := A[0] - 1 downto 1 do
            begin
                t := 0 ; p := A[i] ;
                while ( p <> 0 ) do
                    begin
                        p := p div 10 ;
                        inc ( t ) ;
                    end ;
                for j := 1 to nbase - t do
                    write ( g, '0' ) ;
                if ( A[i] <> 0 ) then
                    write ( g, A[i] ) ;
            end ;
        writeln ( g ) ;
    end;

    function parse ( var x : vec ) : longint ;
    var i , y : longint;

    begin
            i := 1; y := 0;

            while ( i <= k ) do
                begin
                    if ( x[i] >= '0' ) and ( x[i] <= '9' ) then
                        y := y * 10 + ord ( x[i] ) - 48
                    else
                        begin
                            inc ( i ) ;
                            break;
                        end;

                    inc ( i ) ;

                end;

           parse := y ;
    end;

    procedure scrie ( k : qword ) ;
    var i, nr : longint ;
        d : qword ;
        st : string[15] ;
        c : array[1 .. 15] of byte ;

    begin
        nr := 0 ;
        while ( k > 0 ) do
            begin
                inc ( nr ) ;
                d := k div 10 ;
                c[nr] := k - 10 * d + 48 ;
                k := d ;
            end;
       for i := nr downto 1 do
           st[nr - i + 1] := chr ( c[i] ) ;

       st[0] := chr ( nr ) ;

       writeln ( g , st ) ;
    end;

    procedure ciur;
        begin
            for i := 1 to 100000 do
                v[i] := i ;

            i := 2 ;
            while ( i <= 50000 ) do
                begin
                    if ( v[i] = i ) then
                        begin
                            j := i ;
                            while j <= 100000 do
                                begin
                                    v[j] := v[j] div i * ( i - 1 ) ;
                                    j := j + i ;
                                end;
                        end;
                    if ( i = 2 ) then inc ( i, 1 )
                    else inc ( i, 2 ) ;
                end;
        end;

    procedure citire ;
        begin
            readln ( f, N ) ;
        end ;


    procedure main ;
        var A : vec1 ;
        begin
            for i := 1 to N do
                begin
                    read ( f, x ) ; k := length ( x ) ;
                    y := parse ( x ) ; atr ( A, y ) ;
                    mul ( A, v[y] * 2 ) ;
                    scrie ( A ) ;
                    //scrie ( int64 ( v[y] ) * int64 ( y shl 1 ) ) ;
                    readln ( f ) ;
                end;
        end;

    //---------------------
    begin
        fisier ; ciur ; citire ;
        main ;
        close ( f ) ; close ( g ) ;
    end.