Program CorteBidimensional2; Uses CRT; Type REC = record VALOR: Boolean; DIR: char; POS: integer; VDIS: real; end; VET1 = array [0..100] of boolean; VET2 = array [0..100] of word; VET4 = array [0..70,0..80] of REC; Var Horiz,Vert: vet2; P,Q: Vet2; Matriz: Vet4; BoolVet: Vet1; A,B,N,I,J: integer; PERDA: real; KBC : Char; DebugDisplay: boolean; Function DissectHomog (X,Y: integer; var J: integer): real; var W,R,S: real; I: integer; begin W := 0; J := 0; For I := 1 to N do begin R := X div P[i]; S := Y div Q[i]; R := R * S * P[i] * Q[i]; If R > W Then begin W := R; J := I; end; end; DissectHomog := W; If DebugDisplay Then Write('DissectHomog : ',X:3,'x',Y,'- Resultado: ',W:6:2,' Pe‡a :',J:2); end; Procedure AtribuiPosicoesdeCorte(V:vet1; D:word; var Res: vet2); var I,J: word; begin I := 0; Res[0] := 0; For J := 1 to D do If V[j] Then begin I := I + 1; Res[j] := I; end Else Res[j] := I; If DebugDisplay then begin Writeln('AtribuiPosi‡oesCorte :',D:3); Write(' '); For J := 1 to D do Write(Res[j]:3); Writeln; Repeat Until KeyPressed; KBC := ReadKey; end; end; Procedure DetermPosicoesdeCorte(R: vet2; D: word; var Res: vet1); var I,J: word; begin Res[0] := True; For J := 1 to D do Res[j] := False; For I := 1 to N do For J := 0 to D - R[i] do If Res[j] Then Res[j+R[i]] := True; If DebugDisplay then begin Writeln('DetermPosCorte : ',D:3); For J := 0 to D do If Res[j] Then Write(' T ') Else Write(' F '); Writeln; Repeat Until KeyPressed; KBC := ReadKey; end; end; Procedure CalculaMatriz; var L: Rec; V, VVDis, V1: real; I,J,T: integer; K: integer; COMPL: real; begin If DebugDisplay then begin ClrScr; Writeln ('CalculaMatriz : A =',A:4,', B =',B:4); Writeln; For I := 0 to A do Write (Horiz[i]:3); Writeln; For I := 0 to B do Write (Vert[i]:3); Writeln; Repeat until keypressed; KBC := ReadKey; end; Matriz[0,0].Dir := 'O'; Matriz[0,0].Pos := 0; Matriz[0,0].VDis := 0; For I := 1 to B do If Vert[i] <> Vert[i-1] Then For J := 1 to A do If Horiz[j] <> Horiz[j-1] Then begin V := DissectHomog(J,I,T); If T = 0 Then begin Matriz[Vert[i],Horiz[j]].Dir := 'O'; Matriz[Vert[i],Horiz[j]].Pos := 0; Matriz[Vert[i],Horiz[j]].VDis := 0; end Else If V >= J*I Then begin If DebugDisplay then WriteLn(' *** DissHomog *** '); Matriz[Vert[i],Horiz[j]].Dir := 'G'; Matriz[Vert[i],Horiz[j]].Pos := T; Matriz[Vert[i],Horiz[j]].VDis := V; end Else begin VVDis := 0; For K := 1 to J-1 do If Horiz[k] <> horiz[k-1] Then begin If (Horiz[J-K] = 0) or (J-K = 0) Then COMPL := 0 Else COMPL := Matriz[Vert[i],Horiz[j-k]].vdis; V1 := Matriz[Vert[i],Horiz[k]].vdis + COMPL; If V1 > VVDis Then begin L.Dir := 'V'; L.Pos := k; L.VDis := V1; VVDis := V1; end end; For K := 1 to I-1 do If Vert[k] <> Vert[k-1] Then begin If (Vert[I-K] = 0) or (I-K = 0) Then COMPL := 0 Else COMPL := Matriz[Vert[i-k],Horiz[j]].vdis; V1 :=Matriz[Vert[k],Horiz[j]].vdis + COMPL; If V1 > VVDis Then begin L.Dir := 'H'; L.Pos := k; L.VDis := V1; VVDis := V1; end end; If L.Vdis >= V Then begin If DebugDisplay then WriteLn(' *** Heterogˆnea *** '); Matriz[Vert[i],Horiz[j]].Dir := L.Dir; Matriz[Vert[i],Horiz[j]].Pos := L.Pos; Matriz[Vert[i],Horiz[j]].VDis := L.VDis; end Else begin If DebugDisplay then WriteLn(' *** DissHomog *** '); Matriz[Vert[i],Horiz[j]].Dir := 'G'; Matriz[Vert[i],Horiz[j]].Pos := T; Matriz[Vert[i],Horiz[j]].VDis := V; end; end; end; end; Procedure Solucao (I,J: word; X: char); var PlacaX: string[10]; begin If X = ' ' Then PlacaX := 'original '; If X = 'E' Then PlacaX := 'esquerda '; If X = 'D' Then PlacaX := 'direita '; If X = 'B' Then PlacaX := 'de baixo '; If X = 'C' Then PlacaX := 'de cima '; Repeat Until Keypressed; KBC := ReadKey; Write ('Placa ',PlacaX,J:2,' x',I:3,' - '); If Matriz[Vert[i],Horiz[j]].Dir = 'G' Then WriteLn ('Preencha com a pe‡a ',Matriz[Vert[i],Horiz[j]].Pos) Else If Matriz[Vert[i],Horiz[j]].Dir = 'V' Then begin If (Vert[i]=0) or (Horiz[j]=0) Then WriteLn('NÆo pode ser aproveitada !') Else begin WriteLn ('Corte na Vertical, Posi‡ao ',Matriz[Vert[i],Horiz[j]].Pos); Solucao (I,Matriz[Vert[i],Horiz[j]].Pos,'E'); Solucao (I,J-Matriz[Vert[i],Horiz[j]].Pos,'D'); end end Else begin If (Vert[i]=0) or (Horiz[j]=0) Then WriteLn('NÆo pode ser aproveitada !') Else begin WriteLn ('Corte na Horizontal, Posi‡ao ',Matriz[Vert[i],Horiz[j]].Pos); Solucao (Matriz[Vert[i],Horiz[j]].Pos,J,'B'); Solucao (I-Matriz[Vert[i],Horiz[j]].Pos,J,'C'); end; end; end; Begin {$R+U+A+} DebugDisplay:=False; ClrScr; Writeln('*** Corte Otimizado em Duas Dimensoes ***'); Writeln; Writeln; Write ('Quantos modelos de pe‡as serÆo utilizados ? '); Readln (N); Writeln; WriteLn ('Informe o COMPRIMENTO e a LARGURA de cada pe‡a:'); For I := 1 to N do begin Write ('Pe‡a ',I:2,' - '); ReadLn (P[i],Q[i]); end; Writeln;Write ('Informe o COMPRIMENTO e a LARGURA da Placa : '); Readln(A,B); DetermPosicoesdeCorte(P,A,BoolVet); AtribuiPosicoesdeCorte(BoolVet,A,Horiz); DetermPosicoesdeCorte(Q,B,BoolVet); AtribuiPosicoesdeCorte(BoolVet,B,Vert); CalculaMatriz; ClrScr; Writeln('*** Corte Otimizado em Duas Dimensoes ***'); Writeln; Writeln; Writeln('Placa original ........: ',A:3,' x ',B:2); Writeln('Pe‡as: '); For I := 1 to N do Writeln(' ',I:3,' -',P[i]:3,' x ',Q[i]:2); Writeln; Writeln ('Sequencia de Corte/Preenchimento - '); Writeln; Solucao(B,A,' '); PERDA := ( ( A*B - Matriz[Vert[b],Horiz[a]].Vdis) * 100) / (A*B) ; Writeln; Writeln('Esta solu‡Æo desperdi‡a ',PERDA:4:3,'% da placa'); Repeat Until KeyPressed; KBC := ReadKey; ClrScr; End.